[Nek5000-users] Compute the derivatives
nek5000-users at lists.mcs.anl.gov
nek5000-users at lists.mcs.anl.gov
Thu Jul 8 09:59:57 CDT 2010
B
Hi Fred,
If you're using the splitting formulation (lx2=lx1), then there
should be no problem. Otherwise you first need to map pressure
to the velocity mesh (mesh1), which can be done via:
common /scrcg/ pm1 (lx1,ly1,lz1,lelv)
$ ,pa (lx1,ly2,lz2) ,pb (lx1,ly1,lz2)
call mappr(pm1,pr,pa,pb)
Note that for the Pn-Pn-2 method pressure is discontinuous
and of course the same holds for all the derivatives (but
the jumps should be small if you are well-resolved).
Paul
PS - note to group: mappr may need to be fixed for axisymm. case..
On Wed, 7 Jul 2010, nek5000-users at lists.mcs.anl.gov wrote:
> Hi NEKs,
>
> for the validation of my simulation I need the 1st derivative of the
> pressure and the 2nd of the velocity. When I use twice "call gradm1" to
> calculate and "call outpost" to write the 2nd derivative for my velocity
> field it works pretty well. But for the pressure field it goes wrong. I
> think this is due to the fact, that the pressure meshed differently compared
> to the velocity field. Does there exist a subroutine to calculate the
> derivatives of the pressure or do I have to write something by my own??
>
> Thanks a lot.
>
> Best, Fred
>
> _______________________________________________
> Nek5000-users mailing list
> Nek5000-users at lists.mcs.anl.gov
> https://lists.mcs.anl.gov/mailman/listinfo/nek5000-users
>
c-----------------------------------------------------------------------
subroutine prepost(ifdoin,prefin)
c Store results for later postprocessing
c
c Recent updates:
c
c p65 now indicates the number of parallel i/o files; iff p66 >= 6
c
include 'SIZE'
include 'TOTAL'
include 'CTIMER'
C
C Work arrays and temporary arrays
C
common /scrcg/ pm1 (lx1,ly1,lz1,lelv)
c
c note, this usage of CTMP1 will be less than elsewhere if NELT ~> 3.
parameter (lxyz=lx1*ly1*lz1)
parameter (lpsc9=ldimt+9)
common /ctmp1/ tdump(lxyz,lpsc9)
real*4 tdump
real tdmp(4)
equivalence (tdump,tdmp)
real*4 test_pattern
c
character*3 prefin,prefix
character*1 fhdfle1(132)
character*132 fhdfle
equivalence (fhdfle,fhdfle1)
character*1 fldfile2(120)
integer fldfilei( 60)
equivalence (fldfilei,fldfile2)
c
c
common /doit/ ifdoit
logical ifdoit
logical ifdoin
C
C
real hdump(25)
real xpart(10),ypart(10),zpart(10)
character*10 frmat
integer nopen(99)
save nopen
data nopen /99*0/
common /rdump/ ntdump
data ndumps / 0 /
c
logical ifhis
c
integer maxstep
save maxstep
data maxstep /999999999/
if (iostep.lt.0 .or. timeio.lt.0) return
#ifndef NOTIMER
icalld=icalld+1
nprep=icalld
etime1=dnekclock()
#endif
c Trigger history output only if prefix = 'his' pff 8/18/05
ifhis = .false.
prefix = prefin
if (prefin.eq.'his') ifhis = .true.
if (prefix.eq.'his') prefix = ' '
if(icalld.eq.0) then
ierr = 0
if (nid.eq.0) then
write(6,*) 'schfile:',schfle
open(unit=26,file=schfle,err=44,form='formatted',
& status='new')
goto 45
44 ierr = 1
45 endif
call err_chk(ierr,'.sch file already exists.$')
endif
call prepost_map(0) ! map pr and axisymm. arrays
if(istep .ge. nsteps) lastep=1
timdump=0
if(timeio.ne.0.0)then
if(time .ge. (ntdump + 1) * timeio) then
timdump=1.
ntdump=ntdump+1
endif
endif
if (istep.gt.0 .and. iostep.gt.0) then
if(mod(istep,iostep) .eq. 0) ifdoit=.true.
endif
! check for io request in file 'ioinfo'
iiidmp=0
if (nid.eq.0 .and. (mod(istep,10).eq.0 .or. istep.lt.200)) then
open(unit=87,file='ioinfo',status='old',err=88)
read(87,*,end=87,err=87) idummy
if (iiidmp.eq.0) iiidmp=idummy
if (idummy.ne.0) then ! overwrite last i/o request
rewind(87)
write(87,86)
86 format(' 0')
endif
87 continue
close(unit=87)
88 continue
if (iiidmp.ne.0) write(6,*) 'Output:',iiidmp
endif
tdmp(1)=iiidmp
call gop(tdmp,tdmp(3),'+ ',1)
iiidmp= tdmp(1)
if (iiidmp.lt.0) maxstep=abs(iiidmp)
if (istep.ge.maxstep.or.iiidmp.eq.-2) lastep=1
if (iiidmp.eq.-2) return
if (iiidmp.lt.0) iiidmp = 0
if (ifdoin) ifdoit=.true.
if (iiidmp.ne.0.or.lastep.eq.1.or.timdump.eq.1.) ifdoit=.true.
if (ifdoit) call outfld(prefix)
call outhis(ifhis)
call prepost_map(1) ! map back axisymm. arrays
if (lastep.eq.1 .and. nid.eq.0) close(unit=26)
#ifndef NOTIMER
tprep=tprep+dnekclock()-etime1
#endif
ifdoit=.false.
return
end
c-----------------------------------------------------------------------
subroutine prepost_map(isave) ! isave=0-->fwd, isave=1-->bkwd
c Store results for later postprocessing
include 'SIZE'
include 'TOTAL'
C
C Work arrays and temporary arrays
C
common /scruz/ vxax (lx1,ly1,lelv)
$ , vyax (lx1,ly1,lelv)
$ , prax (lx2,ly2,lelv)
$ , yax (lx1,ly1,lelt)
common /scrmg/ tax (lx1,ly1,lelt,ldimt)
common /scrcg/ pm1 (lx1,ly1,lz1,lelv)
C
c
common /prepst/ pa(lx1,ly2,lz2),pb(lx1,ly1,lz2)
integer e
if (isave.eq.0) then ! map to GLL grid
if (ifaxis) then
ntotm1 = nx1*ny1*nelt
call copy (yax,ym1,ntotm1)
do 5 e=1,nelt
if (ifrzer(e)) then
call mxm (ym1(1,1,1,e),nx1,iatjl1,ny1,pb,ny1)
call copy (ym1(1,1,1,e),pb,nx1*ny1)
endif
5 continue
if (ifflow) then
ntotm1 = nx1*ny1*nelv
ntotm2 = nx2*ny2*nelv
call copy (vxax,vx,ntotm1)
call copy (vyax,vy,ntotm1)
call copy (prax,pr,ntotm2)
do 10 e=1,nelv
if (ifrzer(e)) then
call mxm (vx(1,1,1,e),nx1,iatjl1,ny1,pb,ny1)
call copy (vx(1,1,1,e),pb,nx1*ny1)
call mxm (vy(1,1,1,e),nx1,iatjl1,ny1,pb,ny1)
call copy (vy(1,1,1,e),pb,nx1*ny1)
call mxm (pr(1,1,1,e),nx2,iatjl2,ny2,pb,ny2)
call copy (pr(1,1,1,e),pb,nx2*ny2)
endif
10 continue
endif
if (ifheat) then
ntotm1 = nx1*ny1*nelt
do 15 ifldt=1,npscal+1
call copy (tax(1,1,1,ifldt),t(1,1,1,1,ifldt),ntotm1)
15 continue
do 30 e=1,nelt
if (ifrzer(e)) then
do 25 ifldt=1,npscal+1
call mxm (t(1,1,1,e,ifldt),nx1,iatjl1,ny1,
$ pb,ny1)
call copy (t(1,1,1,e,ifldt),pb,nx1*ny1)
25 continue
endif
30 continue
endif
endif
C Map the pressure onto the velocity mesh
C
ntot1 = nx1*ny1*nz1*nelv
nyz2 = ny2*nz2
nxy1 = nx1*ny1
nxyz = nx1*ny1*nz1
C
if (ifsplit) then
call copy(pm1,pr,ntot1)
else
do 1000 e=1,nelv
call mxm (ixm21,nx1,pr(1,1,1,e),nx2,pa(1,1,1),nyz2)
do 100 iz=1,nz2
call mxm (pa(1,1,iz),nx1,iytm21,ny2,pb(1,1,iz),ny1)
100 continue
call mxm (pb(1,1,1),nxy1,iztm21,nz2,pm1(1,1,1,e),nz1)
1000 continue
endif
else ! map back
if (ifaxis) then
ntot1 = nx1*ny1*nelt
call copy (ym1,yax,ntot1)
if (ifflow) then
ntot1 = nx1*ny1*nelv
ntot2 = nx2*ny2*nelv
call copy (vx,vxax,ntot1)
call copy (vy,vyax,ntot1)
call copy (pr,prax,ntot2)
endif
if (ifheat) then
ntot1 = nx1*ny1*nelt
do 3000 ifldt=1,npscal+1
call copy (t(1,1,1,1,ifldt),tax(1,1,1,ifldt),ntot1)
3000 continue
endif
endif
endif
return
end
c-----------------------------------------------------------------------
subroutine outfld(prefix)
c output .fld file
include 'SIZE'
include 'TOTAL'
C
C Work arrays and temporary arrays
C
common /scrcg/ pm1 (lx1,ly1,lz1,lelv)
c
c note, this usage of CTMP1 will be less than elsewhere if NELT ~> 3.
parameter (lxyz=lx1*ly1*lz1)
parameter (lpsc9=ldimt+9)
common /ctmp1/ tdump(lxyz,lpsc9)
real*4 tdump
real tdmp(4)
equivalence (tdump,tdmp)
real*4 test_pattern
character*3 prefix
character*1 fhdfle1(132)
character*132 fhdfle
equivalence (fhdfle,fhdfle1)
character*1 fldfile2(120)
integer fldfilei( 60)
equivalence (fldfilei,fldfile2)
character*1 excode(30)
character*10 frmat
common /nopenf/ nopen(99)
common /rdump/ ntdump
data ndumps / 0 /
if(nid.eq.0) then
WRITE(6,1001) istep,time
1001 FORMAT(/,i9,1pe12.4,' Write checkpoint:')
endif
call gsync()
p66 = abs(param(66))
if (p66.eq.6) then
call mfo_outfld(prefix)
call gsync ! avoid race condition w/ outfld
return
endif
iprefix = i_find_prefix(prefix,99)
if (nid.eq.0) then
c Open new file for each dump on /cfs
NOPEN(iprefix)=NOPEN(iprefix)+1
call file2(nopen(iprefix),prefix)
if (p66.lt.1.0) then
open(unit=24,file=fldfle,form='formatted',status='unknown')
else
call izero (fldfilei,33)
len = ltrunc (fldfle,131)
call chcopy (fldfile2,fldfle,len)
call byte_open (fldfile2)
c write header as character string
call blank(fhdfle,132)
endif
endif
C Figure out what goes in EXCODE
CALL BLANK(EXCODE,30)
NDUMPS=NDUMPS+1
i=1
if (mod(p66,1.0).eq.0.0) then !old header format
IF(IFXYO) then
EXCODE(1)='X'
EXCODE(2)=' '
EXCODE(3)='Y'
EXCODE(4)=' '
i = 5
IF(IF3D) THEN
EXCODE(i) ='Z'
EXCODE(i+1)=' '
i = i + 2
ENDIF
ENDIF
IF(IFVO) then
EXCODE(i) ='U'
EXCODE(i+1)=' '
i = i + 2
ENDIF
IF(IFPO) THEN
EXCODE(i)='P'
EXCODE(i+1)=' '
i = i + 2
ENDIF
IF(IFTO) THEN
EXCODE(i)='T '
EXCODE(i+1)=' '
i = i + 1
ENDIF
IF(NPSCAL.GT.0)then
DO IIP=1,ldimt1
IF(IFPSCO(IIP)) THEN
WRITE(EXCODE(IIP+i) ,'(I1)') IIP
WRITE(EXCODE(IIP+i+1),'(A1)') ' '
i = i + 1
ENDIF
ENDDO
ENDIF
else
!new header format
IF (IFXYO) THEN
EXCODE(i)='X'
i = i + 1
ENDIF
IF (IFVO) THEN
EXCODE(i)='U'
i = i + 1
ENDIF
IF (IFPO) THEN
EXCODE(i)='P'
i = i + 1
ENDIF
IF (IFTO) THEN
EXCODE(i)='T'
i = i + 1
ENDIF
IF (NPSCAL.GT.0) THEN
EXCODE(i) = 'S'
WRITE(EXCODE(i+1),'(I1)') NPSCAL/10
WRITE(EXCODE(i+2),'(I1)') NPSCAL-(NPSCAL/10)*10
ENDIF
endif
c
C Dump header
if (nid.eq.0) call dump_header(excode,p66)
c
call get_id(id)
nxyz = nx1*ny1*nz1
c
do ieg=1,nelgt
c
jnid = gllnid(ieg)
ie = gllel (ieg)
c
if (nid.eq.0) then
if (jnid.eq.0) then
call fill_tmp(tdump,id,ie)
else
mtype=2000+ieg
len=4*id*nxyz
dum1=0.
call csend (mtype,dum1,wdsize,jnid,nullpid)
call crecv (mtype,tdump,len)
endif
call out_tmp(id,p66)
elseif (nid.eq.jnid) then
call fill_tmp(tdump,id,ie)
dum1=0.
c
mtype=2000+ieg
len=4*id*nxyz
call crecv (mtype,dum1,wdsize)
call csend (mtype,tdump,len,node0,nullpid)
endif
enddo
if (nid.eq.0) call close_fld(p66)
call gsync ! avoid race condition w/ outfld
return
end
c-----------------------------------------------------------------------
subroutine outhis(ifhis) ! output time history info
include 'SIZE'
include 'TOTAL'
common /scrcg/ pm1 (lx1,ly1,lz1,lelv)
real hdump(25)
real xpart(10),ypart(10),zpart(10)
character*30 excode
character*10 frmat
logical ifhis
integer icalld
save icalld
data icalld /0/
iohis=1
if (param(52).ge.1) iohis=param(52)
if (mod(istep,iohis).eq.0.and.ifhis) then
if (nhis.gt.0) then
IPART=0
DO 2100 I=1,NHIS
IF(HCODE(10,I).EQ.'P')then
C Do particle paths
IF(IPART.LE.10)IPART=IPART+1
IF(ISTEP.EQ.0)then
C Particle has original coordinates
C Restarts?
XPART(IPART)=
$ XM1(LOCHIS(1,I),LOCHIS(2,I),LOCHIS(3,I),LOCHIS(4,I))
YPART(IPART)=
$ YM1(LOCHIS(1,I),LOCHIS(2,I),LOCHIS(3,I),LOCHIS(4,I))
ZPART(IPART)=
$ ZM1(LOCHIS(1,I),LOCHIS(2,I),LOCHIS(3,I),LOCHIS(4,I))
ELSE
C Kludge: Find Closest point
RMIN=1.0E7
DO 20 IEL=1,NELV
DO 20 K=1,NZ1
DO 20 J=1,NY1
DO 20 II=1,NX1
X = XM1(II,J,K,IEL)
Y = YM1(II,J,K,IEL)
Z = ZM1(II,J,K,IEL)
R=SQRT( (X-XPART(IPART))**2 + (Y-YPART(IPART))**2
$ + (Z-ZPART(IPART))**2 )
IF(R.LT.RMIN) then
RMIN=R
IP=II
JP=J
KP=K
IELP=IEL
ENDIF
20 CONTINUE
XPART(IPART) = XPART(IPART) + DT * VX(IP,JP,KP,IELP)
YPART(IPART) = YPART(IPART) + DT * VY(IP,JP,KP,IELP)
ZPART(IPART) = ZPART(IPART) + DT * VZ(IP,JP,KP,IELP)
ENDIF
C Dump particle data for history point first
C Particle data is Time, x,y,z.
WRITE(26,'(4G14.6,A10)')TIME,XPART(IPART),YPART(IPART)
$ ,ZPART(IPART),' Particle'
ENDIF
C Figure out which fields to dump
NVAR=0
IF(HCODE(10,I).EQ.'H')then
C Do histories
c
c
IX =LOCHIS(1,I)
IY =LOCHIS(2,I)
IZ =LOCHIS(3,I)
IEG=LOCHIS(4,I)
JNID=GLLNID(IEG)
IE =GLLEL(IEG)
C
C------------------------------------------------------------------------
C On first call, write out XYZ location of history points
C
if (icalld.eq.0) then
one = glmax(one,1) ! Force synch. pff 04/16/04
IF (NID.EQ.JNID) then
IF (NP.GT.1.AND..NOT.IF3D)
$ WRITE(6,22) NID,I,IX,IY,ie,IEG
$ ,XM1(IX,IY,IZ,IE),YM1(IX,IY,IZ,IE)
IF (NP.GT.1.AND.IF3D)
$ WRITE(6,23) NID,I,IX,IY,IZ,ie,IEG,XM1(IX,IY,IZ,IE)
$ ,YM1(IX,IY,IZ,IE),ZM1(IX,IY,IZ,IE)
IF (NP.EQ.1.AND..NOT.IF3D)
$ WRITE(6,32) I,IX,IY,ie,IEG
$ ,XM1(IX,IY,IZ,IE),YM1(IX,IY,IZ,IE)
IF (NP.EQ.1.AND.IF3D)
$ WRITE(6,33) I,IX,IY,IZ,ie,IEG,XM1(IX,IY,IZ,IE)
$ ,YM1(IX,IY,IZ,IE),ZM1(IX,IY,IZ,IE)
22 FORMAT(i6,' History point:',I3,' at (',2(I2,','),
$ 2(I4,','),'); X,Y,Z = (',G12.4,',',G12.4,',',G12.4,').')
23 FORMAT(i6,' History point:',I3,' at (',3(I2,','),
$ 2(I4,','),'); X,Y,Z = (',G12.4,',',G12.4,',',G12.4,').')
32 FORMAT(2X,' History point:',I3,' at (',2(I2,','),
$ 2(I4,','),'); X,Y,Z = (',G12.4,',',G12.4,',',G12.4,').')
33 FORMAT(2X,' History point:',I3,' at (',3(I2,','),
$ 2(I4,','),'); X,Y,Z = (',G12.4,',',G12.4,',',G12.4,').')
ENDIF
ENDIF
C------------------------------------------------------------------------
C
IF(HCODE(1,I).EQ.'U')then
NVAR=NVAR+1
HDUMP(NVAR)=VX(IX,IY,IZ,IE)
elseif(HCODE(1,I).EQ.'X')then
NVAR=NVAR+1
HDUMP(NVAR)=XM1(IX,IY,IZ,IE)
ENDIF
IF(HCODE(2,I).EQ.'V')then
NVAR=NVAR+1
HDUMP(NVAR)=VY(IX,IY,IZ,IE)
elseif(HCODE(2,I).EQ.'Y')then
NVAR=NVAR+1
HDUMP(NVAR)=YM1(IX,IY,IZ,IE)
ENDIF
IF(HCODE(3,I).EQ.'W')then
NVAR=NVAR+1
HDUMP(NVAR)=VZ(IX,IY,IZ,IE)
elseif(HCODE(3,I).EQ.'Z')then
NVAR=NVAR+1
HDUMP(NVAR)=ZM1(IX,IY,IZ,IE)
ENDIF
IF(HCODE(4,I).EQ.'P')then
NVAR=NVAR+1
HDUMP(NVAR)=PM1(IX,IY,IZ,IE)
ENDIF
IF(HCODE(5,I).EQ.'T')then
NVAR=NVAR+1
HDUMP(NVAR)=T (IX,IY,IZ,IE,1)
ENDIF
IF(HCODE(6,I).NE.' '.AND. HCODE(6,I).NE.'0') then
READ(HCODE(6,I),'(I1)',ERR=13)IHISPS
13 CONTINUE
C Passive scalar data here
NVAR=NVAR+1
HDUMP(NVAR)=T (IX,IY,IZ,IE,IHISPS+1)
ENDIF
C
C--------------------------------------------------------------
C Dump out the NVAR values for this history point
C--------------------------------------------------------------
MTYPE=2200+I
LEN=WDSIZE*NVAR
C
C If point on this processor, send data to node 0
IF (NVAR.GT.0.AND.NID.NE.0.AND.JNID.EQ.NID)
$ call csend (mtype,hdump,len,node0,nullpid)
C
C If processor 0, recv data (unless point resides on node0).
IF (NVAR.GT.0.AND.NID.EQ.0.AND.JNID.NE.NID)
$ call crecv (mtype,hdump,len)
C
IF (NVAR.GT.0.AND.NID.EQ.0)
$ WRITE(26,'(1p6e16.8)')TIME,(HDUMP(II),II=1,NVAR)
C
C--------------------------------------------------------------
C End of history points
C--------------------------------------------------------------
ENDIF
2100 CONTINUE
C Now do Integrated quantities (Drag, Lift, Flux, etc.)
C Find out which groups are to be dumped
IF (IFINTQ) CALL INTGLQ
DO 2200 IH=1,NHIS
IF(HCODE(10,IH).EQ.'I') then
IOBJ=LOCHIS(1,IH)
ISK=0
DO 2205 IQ=1,3
IF (HCODE(IQ,IH).NE.' ') ISK=ISK + 1
2205 CONTINUE
DO 2207 IQ=5,6
IF (HCODE(IQ,IH).NE.' ') ISK=ISK + 1
2207 CONTINUE
IF (NID.EQ.0)
$ WRITE(26,'(1p6e16.8)')TIME,(QINTEG(II,IOBJ),II=1,ISK)
ENDIF
2200 CONTINUE
ENDIF
endif
icalld = icalld+1
return
end
c-----------------------------------------------------------------------
subroutine intglq
C
include 'SIZE'
include 'SOLN'
include 'INPUT'
include 'PARALLEL'
include 'TSTEP'
common /scrvx/ ts (lx1,ly1,lz1,lelt)
$ , smult(lx1,ly1,lz1,lelt)
common /scrsx/ sfx (lx1,ly1,lz1,lelt)
$ , sfy (lx1,ly1,lz1,lelt)
$ , sfz (lx1,ly1,lz1,lelt)
C
NTOT1 = LX1*LY1*LZ1*LELV
NINTQ = LDIMT3*MAXOBJ
CALL RZERO (QINTEG,NINTQ)
CALL SETSMU (SMULT)
C
IF (IFFLOW) then
CALL COPY (SFX,BFX,NTOT1)
CALL COPY (SFY,BFY,NTOT1)
IF (NDIM.EQ.3) CALL COPY (SFZ,BFZ,NTOT1)
CALL BDFORCE
ENDIF
C
IF (IFHEAT) CALL BDHEAT
C
DO 100 II=1,NHIS
IF (HCODE(10,II).NE.'I') GOTO 100
IOBJ = LOCHIS(1,II)
MEMTOT = NMEMBER(IOBJ)
C
C Fluid flow field
C
IF (HCODE(1,II).NE.' ' .OR. HCODE(2,II).NE.' ' .OR.
$ HCODE(3,II).NE.' ' ) then
IFIELD = 1
NTOT1 = NX1*NY1*NZ1*NELV
CALL COPY (TS,SMULT,NTOT1)
CALL DSSUM (TS,NX1,NY1,NZ1)
DO 150 MEM=1,MEMTOT
ISK = 0
IEG = OBJECT(IOBJ,MEM,1)
IFC = OBJECT(IOBJ,MEM,2)
IF (GLLNID(IEG).EQ.NID) then
C This processor has a contribution
IEL = GLLEL(IEG)
IF (HCODE(1,II).NE.' ') then
ISK = ISK + 1
QINTEG(ISK,IOBJ) = QINTEG(ISK,IOBJ) +
$ SUMFC(BFX(1,1,1,IEL),TS(1,1,1,IEL),IFC)
ENDIF
IF (HCODE(2,II).NE.' ') then
ISK = ISK + 1
QINTEG(ISK,IOBJ) = QINTEG(ISK,IOBJ) +
$ SUMFC(BFY(1,1,1,IEL),TS(1,1,1,IEL),IFC)
ENDIF
IF (HCODE(3,II).NE.' ') then
ISK = ISK + 1
QINTEG(ISK,IOBJ) = QINTEG(ISK,IOBJ) +
$ SUMFC(BFZ(1,1,1,IEL),TS(1,1,1,IEL),IFC)
ENDIF
ENDIF
150 CONTINUE
ENDIF
C
C Temperature field
C
IF (HCODE(5,II).NE.' ') then
IFIELD = 2
NTOT1 = NX1*NY1*NZ1*NELT
CALL COPY (TS,SMULT,NTOT1)
CALL DSSUM (TS,NX1,NY1,NZ1)
ISK=1
DO 170 IQ=1,3
IF (HCODE(IQ,II).NE.' ') ISK=ISK + 1
170 CONTINUE
DO 180 MEM=1,MEMTOT
IEG = OBJECT(IOBJ,MEM,1)
IFC = OBJECT(IOBJ,MEM,2)
IF (GLLNID(IEG).EQ.NID) then
C This processor has a contribution
IEL = GLLEL(IEG)
c call outmat(t,nx1,nx1,'t out',mem)
c call outmat(bq,nx1,nx1,'bq out',ifc)
c call outmat(ts,nx1,nx1,'bq out',mem)
QINTEG(ISK,IOBJ)=QINTEG(ISK,IOBJ) -
$ SUMFC(BQ(1,1,1,IEL,IFIELD-1),TS(1,1,1,IEL),IFC)
ENDIF
180 CONTINUE
ENDIF
c call exitt
C
C One passive scalar field
C
IF (HCODE(6,II).NE.' ' .AND. HCODE(6,II).NE.'0') then
READ (HCODE(6,II),'(I1)',ERR=210) INTQPS
210 CONTINUE
IFIELD = INTQPS + 2
NEL = NELFLD(IFIELD)
NTOT1 = NX1*NY1*NZ1*NEL
CALL COPY (TS,SMULT,NTOT1)
CALL DSSUM (TS,NX1,NY1,NZ1)
ISK=1
DO 270 IQ=1,3
IF (HCODE(IQ,II).NE.' ') ISK=ISK + 1
270 CONTINUE
IF (HCODE(5,II).NE.' ') ISK=ISK + 1
DO 280 MEM=1,MEMTOT
IEG = OBJECT(IOBJ,MEM,1)
IFC = OBJECT(IOBJ,MEM,2)
IF (GLLNID(IEG).EQ.NID) then
C This processor has a contribution
IEL = GLLEL(IEG)
QINTEG(ISK,IOBJ)=QINTEG(ISK,IOBJ) -
$ SUMFC(BQ(1,1,1,IEL,IFIELD-1),TS(1,1,1,IEL),IFC)
ENDIF
280 CONTINUE
ENDIF
C
ISK=0
DO 310 IQ=1,6
IF (HCODE(IQ,II).EQ.' ') GOTO 310
ISK = ISK + 1
QINTEG(ISK,IOBJ) = GLSUM (QINTEG(ISK,IOBJ),1)
310 CONTINUE
C
100 CONTINUE
C
IF (IFFLOW) then
CALL COPY (BFX,SFX,NTOT1)
CALL COPY (BFY,SFY,NTOT1)
IF (NDIM.EQ.3) CALL COPY (BFZ,SFZ,NTOT1)
ENDIF
C
return
end
c=======================================================================
subroutine bdforce
C
C-----------------------------------------------------------------------
C
C Compute total boundary force (components BFX,BFY,BFZ) on objects
C
C Sign convention : these are the force exerted by
C the fluid on the object
C
C-----------------------------------------------------------------------
C
include 'SIZE'
include 'SOLN'
include 'TSTEP'
include 'INPUT'
common /scrvh/ h1 (lx1,ly1,lz1,lelv)
$ , h2 (lx1,ly1,lz1,lelv)
common /scruz/ ta1(lx1,ly1,lz1,lelv)
$ , ta2(lx1,ly1,lz1,lelv)
$ , ta3(lx1,ly1,lz1,lelv)
C
ITEMP = 0
DO 100 II=1,NHIS
IF (HCODE(10,II).NE.'I') GOTO 100
IF (HCODE (1,II).NE.' ' .OR. HCODE(2,II).NE.' ' .OR.
$ HCODE (3,II).NE.' ') ITEMP=ITEMP + 1
100 CONTINUE
C
IF (ITEMP.GT.0) then
C
INTYPE = 0
IF (IFTRAN) INTYPE = -1
IFIELD = 1
IMESH = 1
MATMOD = 0
NTOT1 = NX1*NY1*NZ1*NELV
C
IF (IFSTRS) then
CALL OPCHSGN (BFX,BFY,BFZ)
CALL BCNEUTR
CALL TWALLSH
CALL OPCHSGN (BFX,BFY,BFZ)
ENDIF
CALL SETHLM (H1,H2,INTYPE)
CALL OPGRADT (TA1,TA2,TA3,PR)
CALL ADD2 (BFX,TA1,NTOT1)
IF (.NOT.IFAXIS) CALL ADD2 (BFY,TA2,NTOT1)
IF ( NDIM.EQ.3 ) CALL ADD2 (BFZ,TA3,NTOT1)
CALL AXHMSF (TA1,TA2,TA3,VX,VY,VZ,H1,H2,MATMOD)
CALL SUB2 (BFX,TA1,NTOT1)
IF (.NOT.IFAXIS) CALL SUB2 (BFY,TA2,NTOT1)
IF ( NDIM.EQ.3 ) CALL SUB2 (BFZ,TA3,NTOT1)
IF (IFAXIS) then
TWOPI = 2.0*PI
CALL CMULT (BFX,TWOPI,NTOT1)
CALL RZERO (BFY,NTOT1)
ENDIF
CALL OPDSSUM (BFX,BFY,BFZ)
C
ENDIF
C
return
end
c=======================================================================
subroutine bdheat
C
C-----------------------------------------------------------------------
C
C Compute total boundary flux-area product
C
C Sign convention : flux enters the object from the continuum
C
C
C-----------------------------------------------------------------------
C
include 'SIZE'
include 'SOLN'
include 'TSTEP'
include 'INPUT'
common /scrvh/ h1(lx1,ly1,lz1,lelt)
$ , h2(lx1,ly1,lz1,lelt)
common /scruz/ ta(lx1,ly1,lz1,lelt)
C
INTYPE = 0
IF (IFTRAN) INTYPE = -1
C
C Temperature field
C
ITEMP = 0
DO 100 II=1,NHIS
IF ( HCODE(10,II).NE.'I') GOTO 100
IF ( HCODE( 5,II).NE.' ') ITEMP=ITEMP + 1
100 CONTINUE
IF (ITEMP.GT.0) then
IFIELD = 2
NTOT1 = NX1*NY1*NZ1*NELT
IMESH = 2
CALL BCNEUSC (TA,1)
CALL SUB2 (BQ(1,1,1,1,IFIELD-1),TA,NTOT1)
CALL SETHLM (H1,H2,INTYPE)
CALL AXHELM (TA,T(1,1,1,1,IFIELD-1),H1,H2,IMESH,1)
CALL SUB2 (BQ(1,1,1,1,IFIELD-1),TA,NTOT1)
IF (IFAXIS) then
TWOPI = 2.0*PI
CALL CMULT (BQ(1,1,1,1,IFIELD-1),TWOPI,NTOT1)
ENDIF
CALL DSSUM (BQ(1,1,1,1,IFIELD-1),NX1,NY1,NZ1)
ENDIF
C
C One passive scalar field
C
ITEMP = 0
DO 200 II=1,NHIS
IF ( HCODE(10,II).NE.'I') GOTO 200
IF ( HCODE(6,II).NE.' ' .AND. HCODE(6,II).NE.'0' ) then
READ (HCODE(6,II),'(I1)',ERR=200) INTQPS
ITEMP = ITEMP + 1
ENDIF
200 CONTINUE
IF (ITEMP.GT.0) then
IFIELD = INTQPS + 2
NEL = NELFLD(IFIELD)
NTOT1 = NX1*NY1*NZ1*NEL
IMESH = 1
IF (IFTMSH(IFIELD)) IMESH = 2
CALL BCNEUSC (TA,1)
CALL SUB2 (BQ(1,1,1,1,IFIELD-1),TA,NTOT1)
CALL SETHLM (H1,H2,INTYPE)
CALL AXHELM (TA,T(1,1,1,1,IFIELD-1),H1,H2,IMESH,1)
CALL SUB2 (BQ(1,1,1,1,IFIELD-1),TA,NTOT1)
IF (IFAXIS) then
TWOPI = 2.0*PI
CALL CMULT (BQ(1,1,1,1,IFIELD-1),TWOPI,NTOT1)
ENDIF
CALL DSSUM (BQ(1,1,1,1,IFIELD-1),NX1,NY1,NZ1)
ENDIF
C
return
end
c=======================================================================
subroutine setsmu (smult)
C
include 'SIZE'
include 'INPUT'
include 'PARALLEL'
C
DIMENSION SMULT (LX1,LY1,LZ1,1)
C
NTOT1=NX1*NY1*NZ1*NELT
CALL RZERO (SMULT,NTOT1)
C
DO 100 II=1,NHIS
IF (HCODE(10,II).NE.'I') GOTO 100
IOBJ = LOCHIS(1,II)
MEMTOT = NMEMBER(IOBJ)
DO 150 MEM=1,MEMTOT
IEG = OBJECT(IOBJ,MEM,1)
IFC = OBJECT(IOBJ,MEM,2)
IF (GLLNID(IEG).EQ.NID) then
C This processor has a contribution
IEL = GLLEL(IEG)
CALL FACIND (KX1,KX2,KY1,KY2,KZ1,KZ2,NX1,NY1,NZ1,IFC)
DO 200 IZ=KZ1,KZ2
DO 200 IY=KY1,KY2
DO 200 IX=KX1,KX2
200 SMULT(IX,IY,IZ,IEL)=SMULT(IX,IY,IZ,IEL) + 1.0
ENDIF
150 CONTINUE
100 CONTINUE
C
return
end
FUNCTION SUMFC (FF,SM,IFC)
include 'SIZE'
REAL FF(LX1,LY1,LZ1),SM(LX1,LY1,LZ1)
SUMFC=0.0
CALL FACIND (KX1,KX2,KY1,KY2,KZ1,KZ2,NX1,NY1,NZ1,IFC)
DO 70 IZ=KZ1,KZ2
DO 70 IY=KY1,KY2
DO 70 IX=KX1,KX2
SUMFC=SUMFC + FF(IX,IY,IZ)/SM(IX,IY,IZ)
70 CONTINUE
return
end
c=======================================================================
subroutine file2(nopen,PREFIX)
C----------------------------------------------------------------------
C
C Defines machine specific input and output file names.
C
C----------------------------------------------------------------------
include 'SIZE'
include 'INPUT'
include 'TSTEP'
include 'PARALLEL'
C
CHARACTER*132 NAME
CHARACTER*1 SESS1(132),PATH1(132),NAM1(132)
EQUIVALENCE (SESSION,SESS1)
EQUIVALENCE (PATH,PATH1)
EQUIVALENCE (NAME,NAM1)
CHARACTER*1 DMP(4),FLD(4),REA(4),HIS(4),SCH(4) ,ORE(4), NRE(4)
CHARACTER*4 DMP4 ,FLD4 ,REA4 ,HIS4 ,SCH4 ,ORE4 , NRE4
EQUIVALENCE (DMP,DMP4), (FLD,FLD4), (REA,REA4), (HIS,HIS4)
$ , (SCH,SCH4), (ORE,ORE4), (NRE,NRE4)
CHARACTER*1 NUMRL(0:9)
DATA DMP4,FLD4,REA4 /'.dmp','.fld','.rea'/
DATA HIS4,SCH4 /'.his','.sch'/
DATA ORE4,NRE4 /'.ore','.nre'/
DATA NUMRL /'0','1','2','3','4','5','6','7','8','9'/
CHARACTER*78 STRING
c
character*1 prefix(3)
C
call blank(name ,132)
call blank(fldfle,132)
C
LS=LTRUNC(SESSION,132)
LPP=LTRUNC(PATH,132)
LSP=LS+LPP
l = 0
c Construct file names containing full path to host:
c DO 100 I=1,LPP
c l = l+1
c NAM1(l)=PATH1(I)
c 100 CONTINUE
C
if (prefix(1).ne.' '.and.prefix(2).ne.' '.and.
$ prefix(3).ne.' ') then
do i=1,3
l = l+1
NAM1(l)=prefix(i)
enddo
endif
C
DO 200 I=1,LS
l = l+1
NAM1(l)=SESS1(I)
200 CONTINUE
C
C .fld file
DO 300 I=1,4
l = l+1
NAM1(l)=FLD(I)
300 CONTINUE
if (nopen.lt.100) then
C less than 100 dumps....
ITEN=NOPEN/10
l = l+1
NAM1(l)=NUMRL(ITEN)
IONE=MOD(NOPEN,10)
l = l+1
NAM1(l)=NUMRL(IONE)
elseif (nopen.lt.1000) then
C less than 1000 dumps....
IHUN=NOPEN/100
l = l+1
NAM1(l)=NUMRL(IHUN)
ITEN=MOD(NOPEN,100)/10
l = l+1
NAM1(l)=NUMRL(ITEN)
IONE=MOD(NOPEN,10)
l = l+1
NAM1(l)=NUMRL(IONE)
elseif (nopen.lt.10000) then
C less than 10000 dumps....
ITHO=NOPEN/1000
l = l+1
NAM1(l)=NUMRL(ITHO)
IHUN=MOD(NOPEN,1000)/100
l = l+1
NAM1(l)=NUMRL(IHUN)
ITEN=MOD(NOPEN,100)/10
l = l+1
NAM1(l)=NUMRL(ITEN)
IONE=MOD(NOPEN,10)
l = l+1
NAM1(l)=NUMRL(IONE)
endif
FLDFLE=NAME
C
C Write the name of the .fld file to the logfile.
C
if (nid.eq.0) then
call chcopy(string,fldfle,78)
write(6,1000) istep,time,string
1000 format(/,i9,1pe12.4,' OPEN: ',a78)
endif
return
end
c=======================================================================
subroutine rzero4(a,n)
real*4 A(1)
DO 100 I = 1, N
100 A(I ) = 0.0
return
end
c=======================================================================
subroutine copyX4(a,b,n)
REAL*4 A(1)
REAL B(1)
DO 100 I = 1, N
100 A(I) = B(I)
return
end
c=======================================================================
subroutine copy4r(a,b,n)
real a(1)
real*4 b(1)
do i = 1, n
a(i) = b(i)
enddo
return
end
c=======================================================================
function i_find_prefix(prefix,imax)
c
character*3 prefix
character*3 prefixes(99)
save prefixes
data prefixes /99*'...'/
c
integer nprefix
save nprefix
data nprefix /0/
c
c Scan existing list of prefixes for a match to "prefix"
c
do i=1,nprefix
if (prefix.eq.prefixes(i)) then
i_find_prefix = i
return
endif
enddo
c
c If we're here, we didn't find a match.. bump list and return
c
nprefix = nprefix + 1
prefixes(nprefix) = prefix
i_find_prefix = nprefix
c
c Array bounds check on prefix list
c
if (nprefix.gt.99.or.nprefix.gt.imax) then
write(6,*) 'Hey! nprefix too big! ABORT in i_find_prefix'
$ ,nprefix,imax
call exitt
endif
c
return
end
c-----------------------------------------------------------------------
subroutine dump_header(excodein,p66)
c
include 'SIZE'
include 'TOTAL'
character*30 excodein
c
character*30 excode
character*1 excode1(30)
equivalence (excode,excode1)
c
real*4 test_pattern
c
character*1 fhdfle1(132)
character*132 fhdfle
equivalence (fhdfle,fhdfle1)
write(excode,'(A30)') excodein
c
ikstep = istep
do ik=1,10
if (ikstep.gt.99999) ikstep = ikstep/10
enddo
call blank(fhdfle,132)
c write(6,111) ! print on screen
c $ nelgt,nx1,ny1,nz1,time,istep,excode
c
if (mod(p66,1.0).eq.0.0) then ! old header format
if (p66.lt.1.0) then
WRITE(24,'(4I4,1pe14.7,I5,1X,30A1,1X,A12)')
$ NELGT,NX1,NY1,NZ1,TIME,ikstep,(EXCODE1(I),I=1,30),
$ 'NELT,NX,NY,N'
else
if (nelgt.lt.10000) then
WRITE(fhdfle,'(4I4,1pe14.7,I5,1X,30A1,1X,A12)')
$ NELGT,NX1,NY1,NZ1,TIME,ikstep,(EXCODE1(I),I=1,30),
$ ' 4 NELT,NX,NY,N'
else
write(fhdfle,'(i10,3i4,1P1e18.9,i9,1x,30a1)')
$ nelgt,nx1,ny1,nz1,time,istep,(excode1(i),i=1,30)
endif
call byte_write(fhdfle,20)
endif
else ! new header format
if (p66.eq.0.1) then
write(24,111)
$ nelgt,nx1,ny1,nz1,time,istep,excode
else
write(fhdfle,111)
$ nelgt,nx1,ny1,nz1,time,istep,excode
call byte_write(fhdfle,20)
endif
111 FORMAT(i10,1x,i2,1x,i2,1x,i2,1x,1P1e18.9,1x,i9,1x,a)
endif
CDRROR=0.0
if (p66.LT.1.0) then ! formatted i/o
WRITE(24,'(6G11.4)')(CDRROR,I=1,NELGT) ! dummy
else
C write byte-ordering test pattern to byte file...
test_pattern = 6.54321
call byte_write(test_pattern,1)
endif
c
return
end
c-----------------------------------------------------------------------
subroutine fill_tmp(tdump,id,ie)
C
include 'SIZE'
include 'TOTAL'
c
common /scrcg/ pm1 (lx1,ly1,lz1,lelv)
C
C Fill work array
C
PARAMETER (LXYZ=LX1*LY1*LZ1)
PARAMETER (LPSC9=LDIMT+9)
real*4 tdump(lxyz,lpsc9)
C
nxyz = nx1*ny1*nz1
c
ID=0
IF(IFXYO)then
ID=ID+1
CALL COPYx4(TDUMP(1,ID),XM1(1,1,1,IE),NXYZ)
ID=ID+1
CALL COPYx4(TDUMP(1,ID),YM1(1,1,1,IE),NXYZ)
IF(IF3D) then
ID=ID+1
CALL COPYx4(TDUMP(1,ID),ZM1(1,1,1,IE),NXYZ)
ENDIF
ENDIF
c
IF(IFVO)then
IF (IE.LE.NELV) then
ID=ID+1
CALL COPYx4(TDUMP(1,ID),VX(1,1,1,IE),NXYZ)
ID=ID+1
CALL COPYx4(TDUMP(1,ID),VY(1,1,1,IE),NXYZ)
IF(IF3D)then
ID=ID+1
CALL COPYx4(TDUMP(1,ID),VZ(1,1,1,IE),NXYZ)
ENDIF
ELSE
ID=ID+1
CALL RZERO4(TDUMP(1,ID),NXYZ)
ID=ID+1
CALL RZERO4(TDUMP(1,ID),NXYZ)
IF(IF3D)then
ID=ID+1
CALL RZERO4(TDUMP(1,ID),NXYZ)
ENDIF
ENDIF
ENDIF
IF(IFPO)then
IF (IE.LE.NELV) then
ID=ID+1
CALL COPYx4(TDUMP(1,ID),PM1(1,1,1,IE),NXYZ)
ELSE
ID=ID+1
CALL RZERO4(TDUMP(1,ID),NXYZ)
ENDIF
ENDIF
IF(IFTO)then
ID=ID+1
CALL COPYx4(TDUMP(1,ID),T(1,1,1,IE,1),NXYZ)
ENDIF
C PASSIVE SCALARS
IF(NPSCAL.GT.0)then
DO IIP=1,ldimt1
IF(IFPSCO(IIP))then
ID=ID+1
CALL COPYx4(TDUMP(1,ID),T(1,1,1,IE,IIP+1),NXYZ)
ENDIF
ENDDO
ENDIF
c
return
end
c-----------------------------------------------------------------------
subroutine get_id(id)
C
include 'SIZE'
include 'TOTAL'
C
C Count up amount of data to be shipped
C
ID=0
IF(IFXYO)then
ID=ID+1
ID=ID+1
IF(IF3D) then
ID=ID+1
ENDIF
ENDIF
c
IF(IFVO)then
ID=ID+1
ID=ID+1
IF(IF3D)then
ID=ID+1
ENDIF
ENDIF
IF(IFPO) ID=ID+1
IF(IFTO) ID=ID+1
C PASSIVE SCALARS
IF(NPSCAL.GT.0)then
DO IIP=1,ldimt1
IF(IFPSCO(IIP))then
ID=ID+1
ENDIF
ENDDO
ENDIF
c
return
end
c-----------------------------------------------------------------------
subroutine close_fld(p66)
include 'SIZE'
include 'TOTAL'
if (nid.eq.0) then
if (p66.lt.1) then
close(unit=24)
else
call byte_close()
endif
endif
return
end
c-----------------------------------------------------------------------
subroutine out_tmp(id,p66)
c
include 'SIZE'
include 'TOTAL'
c
PARAMETER (LXYZ=LX1*LY1*LZ1)
PARAMETER (LPSC9=LDIMT+9)
c
common /ctmp1/ tdump(lxyz,lpsc9)
real*4 tdump
c
CHARACTER*11 FRMAT
c
nxyz = nx1*ny1*nz1
c
call blank(frmat,11)
if (id.le.9) then
WRITE(FRMAT,1801) ID
1801 FORMAT('(1p',I1,'e14.6)')
else
WRITE(FRMAT,1802) ID
1802 FORMAT('(1p',I2,'e14.6)')
endif
if (p66.lt.1.0) then
C formatted i/o
WRITE(24,FRMAT)
$ ((TDUMP(I,II),II=1,ID),I=1,NXYZ)
else
c C binary i/o
do ii=1,id
call byte_write(tdump(1,ii),nxyz)
enddo
endif
c
return
end
c-----------------------------------------------------------------------
subroutine mfo_outfld(prefix) ! muti-file output
include 'SIZE'
include 'TOTAL'
include 'RESTART'
common /scrcg/ pm1 (lx1,ly1,lz1,lelv) ! mapped pressure
integer*8 offs0,offs,nbyte,stride,strideB,nxyzo8
character*3 prefix
logical ifxyo_s
common /SCRUZ/ ur1(lxo*lxo*lxo*lelt)
& , ur2(lxo*lxo*lxo*lelt)
& , ur3(lxo*lxo*lxo*lelt)
tiostart=dnekclock()
ifxyo_s = ifxyo
ifxyo_ = ifxyo
nout = nelt
nxo = nx1
nyo = ny1
nzo = nz1
if (ifreguo) then ! dump on regular (uniform) mesh
if (nrg.gt.lxo) then
if (nid.eq.0) write(6,*)
& 'WARNING: nrg too large, reset to lxo!'
nrg = lxo
endif
nxo = nrg
nyo = nrg
nzo = 1
if(if3d) nzo = nrg
endif
offs0 = iHeaderSize + 4 + isize*nelgt
if (nid.eq.pid0) then
call mfo_open_files(prefix) ! open files on i/o nodes
endif
call bcast(ifxyo_,lsize)
ifxyo = ifxyo_
call mfo_write_hdr ! create element mapping +
! write hdr
nxyzo8 = nxo*nyo*nzo
strideB = nelB * nxyzo8*wdsizo
stride = nelgt* nxyzo8*wdsizo
ioflds = 0
! dump all fields based on the t-mesh to avoid different
! topologies in the post-processor
if (ifxyo) then
c stefan: we need to change fldstideB to the number of elements
offs = offs0 + ndim*strideB
call byte_set_view(offs)
if (ifreguo) then
call map2reg(ur1,nrg,xm1,nout)
call map2reg(ur2,nrg,ym1,nout)
if (if3d) call map2reg(ur3,nrg,zm1,nout)
call mfo_outv(ur1,ur2,ur3,nout,nxo,nyo,nzo)
else
call mfo_outv(xm1,ym1,zm1,nout,nxo,nyo,nzo)
endif
ioflds = ioflds + ndim
endif
if (ifvo ) then
offs = offs0 + ioflds*stride + ndim*strideB
call byte_set_view(offs)
if (ifreguo) then
call map2reg(ur1,nrg,vx,nout)
call map2reg(ur2,nrg,vy,nout)
if (if3d) call map2reg(ur3,nrg,vz,nout)
call mfo_outv(ur1,ur2,ur3,nout,nxo,nyo,nzo)
else
call mfo_outv(vx,vy,vz,nout,nxo,nyo,nzo) ! B-field handled thru outpost
endif
ioflds = ioflds + ndim
endif
if (ifpo ) then
offs = offs0 + ioflds*stride + strideB
call byte_set_view(offs)
if (ifreguo) then
call map2reg(ur1,nrg,pm1,nout)
call mfo_outs(ur1,nout,nxo,nyo,nzo)
else
call mfo_outs(pm1,nout,nxo,nyo,nzo)
endif
ioflds = ioflds + 1
endif
if (ifto ) then
offs = offs0 + ioflds*stride + strideB
call byte_set_view(offs)
if (ifreguo) then
call map2reg(ur1,nrg,t,nout)
call mfo_outs(ur1,nout,nxo,nyo,nzo)
else
call mfo_outs(t,nout,nxo,nyo,nzo)
endif
ioflds = ioflds + 1
endif
do k=1,ldimt-1
if(ifpsco(k)) then
offs = offs0 + ioflds*stride + strideB
call byte_set_view(offs)
if (ifreguo) then
call map2reg(ur1,nrg,t(1,1,1,1,k+1),nout)
call mfo_outs(ur1,nout,nxo,nyo,nzo)
else
call mfo_outs(t(1,1,1,1,k+1),nout,nxo,nyo,nzo)
endif
ioflds = ioflds + 1
endif
enddo
nbyte = ioflds*nout*wdsizo*nxo*nyo*nzo
if (if3d) then
offs0 = offs0 + ioflds*stride
strideB = nelB *2*4 ! min/max single precision
stride = nelgt*2*4
ioflds = 0
! add meta data to the end of the file
if (ifxyo) then
offs = offs0 + ndim*strideB
call byte_set_view(offs)
call mfo_mdatav(xm1,ym1,zm1,nout)
ioflds = ioflds + ndim
endif
if (ifvo ) then
offs = offs0 + ioflds*stride + ndim*strideB
call byte_set_view(offs)
call mfo_mdatav(vx,vy,vz,nout)
ioflds = ioflds + ndim
endif
if (ifpo ) then
offs = offs0 + ioflds*stride + strideB
call byte_set_view(offs)
call mfo_mdatas(pm1,nout)
ioflds = ioflds + 1
endif
if (ifto ) then
offs = offs0 + ioflds*stride + strideB
call byte_set_view(offs)
call mfo_mdatas(t,nout)
ioflds = ioflds + 1
endif
do k=1,ldimt-1
offs = offs0 + ioflds*stride + strideB
call byte_set_view(offs)
if(ifpsco(k)) call mfo_mdatas(t(1,1,1,1,k+1),nout)
ioflds = ioflds + 1
enddo
nbyte = nbyte + 2*ioflds*nout*wdsizo
endif
if (nid.eq.pid0)
#ifdef MPIIO
& call byte_close_mpi()
#else
& call byte_close()
#endif
call gsync()
tio = dnekclock()-tiostart
dnbyte = nbyte
nbyte = glsum(dnbyte,1)
nbyte = nbyte + iHeaderSize + 4 + isize*nelgt
if(nid.eq.0) write(6,7) istep,time,
& nbyte/tio/1024/1024/10,
& nfileo
7 format(/,i9,1pe12.4,' done :: Write checkpoint',/,
& 30X,'avg data-throughput = ',f7.1,'MBps',/,
& 30X,'io-nodes = ',i5,/)
ifxyo = ifxyo_s ! restore old value
return
end
c-----------------------------------------------------------------------
subroutine io_init ! determine which nodes will output
character*132 hname
include 'SIZE'
include 'INPUT'
include 'PARALLEL'
include 'RESTART'
ifdiro = .false.
#ifdef MPIIO
c#ifdef MPIIO_NOCOL
c nfileo = abs(param(65))
c if(nfileo.eq.0) nfileo = 1
c if(np.lt.nfileo) nfileo=np
c nproc_o = np / nfileo ! # processors pointing to pid0
c fid0 = nid/nproc_o ! file id
c pid0 = nproc_o*fid0 ! my parent i/o node
c pid1 = min(np-1,pid0+nproc_o-1) ! range of sending procs
c fid0 = 0
c#else
nfileo = np
nproc_o = 1
fid0 = 0
pid0 = nid
pid1 = 0
c#endif
#else
if(param(65).lt.0) ifdiro = .true. ! p65 < 0 --> multi subdirectories
nfileo = abs(param(65))
if(nfileo.eq.0) nfileo = 1
if(np.lt.nfileo) nfileo=np
nproc_o = np / nfileo ! # processors pointing to pid0
fid0 = nid/nproc_o ! file id
pid0 = nproc_o*fid0 ! my parent i/o node
pid1 = min(np-1,pid0+nproc_o-1) ! range of sending procs
#endif
call nek_comm_io(nfileo)
wdsizo = 4 ! every proc needs this
if (param(63).gt.0) wdsizo = 8 ! 64-bit .fld file
if (wdsizo.gt.wdsize) then
if(nid.eq.0) write(6,*) 'ABORT: wdsizo > wdsize!'
call exitt
endif
ifreguo = .false. ! by default we dump the data based on the GLL mesh
nrg = lxo
! how many elements are present up to rank nid
nn = nelt
nelB = igl_running_sum(nn)
nelB = nelB - nelt
pid00 = glmin(pid0,1)
return
end
c-----------------------------------------------------------------------
subroutine mfo_open_files(prefix) ! open files
include 'SIZE'
include 'INPUT'
include 'PARALLEL'
include 'RESTART'
character*1 prefix(3)
character*132 fname
character*1 fnam1(132)
equivalence (fnam1,fname)
character*6 six,str
save six
data six / "??????" /
character*1 slash,dot
save slash,dot
data slash,dot / '/' , '.' /
integer nopen(99,2)
save nopen
data nopen / 198*0 /
call blank(fname,132) ! zero out for byte_open()
iprefix = i_find_prefix(prefix,99)
if (ifreguo) then
nopen(iprefix,2) = nopen(iprefix,2)+1
nfld = nopen(iprefix,2)
else
nopen(iprefix,1) = nopen(iprefix,1)+1
nfld = nopen(iprefix,1)
endif
call restart_nfld( nfld, prefix ) ! Check for Restart option.
if (nfld.eq.1) ifxyo_ = .true.
#ifdef MPIIO
rfileo = 1
#else
rfileo = nfileo
#endif
ndigit = log10(rfileo) + 1
k = 1
if (ifdiro) then ! Add directory
call chcopy(fnam1(1),'A',1)
call chcopy(fnam1(2),six,ndigit) ! put ???? in string
k = 2 + ndigit
call chcopy(fnam1(k),slash,1)
k = k+1
endif
if (prefix(1).ne.' '.and.prefix(2).ne.' '.and. ! Add prefix
$ prefix(3).ne.' ') then
call chcopy(fnam1(k),prefix,3)
k = k+3
endif
len=ltrunc(session,132) ! Add SESSION
call chcopy(fnam1(k),session,len)
k = k+len
if (ifreguo) then
len=4
call chcopy(fnam1(k),'_reg',len)
k = k+len
endif
call chcopy(fnam1(k),six,ndigit) ! Add file-id holder
k = k + ndigit
call chcopy(fnam1(k ),dot,1) ! Add .f appendix
call chcopy(fnam1(k+1),'f',1)
k = k + 2
write(str,4) nfld ! Add nfld number
4 format(i5.5)
call chcopy(fnam1(k),str,5)
k = k + 5
call mbyte_open(fname,fid0) ! Open blah000.fnnnn
c write(6,*) nid,fid0,' FILE:',fname
return
end
c-----------------------------------------------------------------------
subroutine restart_nfld( nfld, prefix )
character*3 prefix
c
c Check for Restart option and return proper nfld value.
c Also, convenient spot to explain restart strategy.
c
c
c The approach is as follows:
c
c Prefix rs4 would indicate 4 files in the restart cycle.
c
c This would be normal usage for velocity only, with
c checkpoints taking place in synch with standard io.
c
c The resultant restart sequence might look like:
c
c blah.fld09 Step 0
c rs4blah.fld01 1
c rs4blah.fld02 2
c
c which implies that fld09 would be used as the i.c.
c in the restart, rs4blah.fld01 would overwrite the
c solution at Step 1, and rs4blah.fld02 would overwrite
c Step 2. Net result is that Steps 0-2 of the restart
c session have solutions identical to those computed in
c the prior run. (It's important that both runs use
c the same dt in this case.)
c
c
c Another equally possible restart sequence would be:
c
c
c blah.fld10 Step 0
c rs4blah.fld03 1
c rs4blah.fld04 2
c
c Why the 3 & 4 ? If one were to use only 1 & 2, there
c is a risk that the system crashes while writing, say,
c rs4blah.fld01, in which case the restart is compromised --
c very frustrating at the end of a run that has been queued
c for a week. By providing a toggled sequence in pairs such as
c
c (1,2), (3,4), (1,2), ...
c
c ensures that one always has at least one complete restart
c sequence. In the example above, the following files would
c be written, in order:
c
c :
c :
c blah.fld09
c rs4blah.fld01
c rs4blah.fld02
c blah.fld10
c rs4blah.fld03
c rs4blah.fld04
c blah.fld11
c rs4blah.fld01 (overwriting existing rs4blah.fld01)
c rs4blah.fld02 ( " " " .fld02)
c blah.fld12
c rs4blah.fld03 ( etc. )
c rs4blah.fld04
c :
c :
c
c
c Other strategies are possible, according to taste.
c
c Here is a data-intensive one:
c
c MHD + double-precision restart, but single-precision std files
c
c In this case, single-precision files are kept as the running
c file sequence (i.e., for later post-processing) but dbl-prec.
c is required for restart. A total of 12 temporary restart files
c must be saved: (3 for velocity, 3 for B-field) x 2 for redundancy.
c
c This is expressed, using hexadecimal notation (123456789abc...),
c as prefix='rsc'.
c
c
character*16 kst
save kst
data kst / '0123456789abcdef' /
character*1 ks1(0:15),kin
equivalence (ks1,kst)
c
c
if (indx1(prefix,'rs',2).eq.1) then
read(prefix,3) kin
3 format(2x,a1)
do kfld=1,15
if (ks1(kfld).eq.kin) goto 10
enddo
10 if (kfld.eq.16) kfld=4 ! std. default
nfln = mod1(nfld,kfld) ! Restart A (1,2) and B (3,4)
write(6,*) nfln,nfld,kfld,' kfld'
nfld = nfln
endif
return
end
c-----------------------------------------------------------------------
subroutine restart_save(iosave,save_size,nfldi)
integer iosave,save_size,kfld
c Save current fields for later restart.
c
c Input arguments:
c
c .iosave plays the usual triggering role, like iostep
c
c .save_size = 8 ==> dbl. precision output
c
c .kfld is the number of rs files to save before overwriting
c
include 'SIZE'
include 'TOTAL'
character*3 prefix
character*16 kst
save kst
data kst / '0123456789abcdef' /
character*1 ks1(0:15)
equivalence (ks1,kst)
iosav = iosave
if (iosav.eq.0) iosav = iostep
if (iosav.eq.0) return
iotest = 0
c if (iosav.eq.iostep) iotest = 1 ! currently spoiled because of
c ! incompatible format of .fld
c ! and multi-file i/o; the latter
c ! is the only form used for restart
nfld = nfldi*2
nfld2 = nfld/2
if (ifmhd) nfld2 = nfld/4
if (istep.gt.iosav/2 .and.
$ mod(istep+iosav-iotest,iosav).lt.nfld2) then ! save
write(prefix,3) ks1(nfld)
3 format('rs',a1)
p63 = param(63) ! save existing p63, p66
p66 = param(66)
if (save_size.eq.8) param(63) = 8 ! output precision
param(66) = 6 ! force multi-file out
if (ifmhd) call outpost2(bx,by,bz,pm,t,1,prefix) ! first B
call outpost2(vx,vy,vz,pr,t,1,prefix) ! then U
param(63) = p63 ! restore p63, p66
param(66) = p66
endif
return
end
c-----------------------------------------------------------------------
subroutine mfo_mdatav(u,v,w,nel)
include 'SIZE'
include 'INPUT'
include 'PARALLEL'
include 'RESTART'
real u(lx1*ly1*lz1,1),v(lx1*ly1*lz1,1),w(lx1*ly1*lz1,1)
real*4 buffer(1+6*lelt)
integer e
call gsync() ! clear outstanding message queues.
nxyz = nx1*ny1*nz1
n = 2*ndim
len = 4 + 4*(n*lelt) ! recv buffer size
leo = 4 + 4*(n*nelt)
! Am I an I/O node?
if (nid.eq.pid0) then
j = 1
do e=1,nel
buffer(j+0) = vlmin(u(1,e),nxyz)
buffer(j+1) = vlmax(u(1,e),nxyz)
buffer(j+2) = vlmin(v(1,e),nxyz)
buffer(j+3) = vlmax(v(1,e),nxyz)
j = j + 4
if(if3d) then
buffer(j+0) = vlmin(w(1,e),nxyz)
buffer(j+1) = vlmax(w(1,e),nxyz)
j = j + 2
endif
enddo
! write out my data
nout = n*nel
#ifdef MPIIO
call byte_write_mpi(buffer,nout,-1)
#else
call byte_write(buffer,nout)
#endif
! write out the data of my childs
idum = 1
do k=pid0+1,pid1
mtype = k
call csend(mtype,idum,4,k,0) ! handshake
call crecv(mtype,buffer,len)
inelp = buffer(1)
nout = n*inelp
#ifdef MPIIO
call byte_write_mpi(buffer(2),nout,-1)
#else
call byte_write(buffer(2),nout)
#endif
enddo
else
j = 1
buffer(j) = nel
j = j + 1
do e=1,nel
buffer(j+0) = vlmin(u(1,e),nxyz)
buffer(j+1) = vlmax(u(1,e),nxyz)
buffer(j+2) = vlmin(v(1,e),nxyz)
buffer(j+3) = vlmax(v(1,e),nxyz)
j = j + 4
if(n.eq.6) then
buffer(j+0) = vlmin(w(1,e),nxyz)
buffer(j+1) = vlmax(w(1,e),nxyz)
j = j + 2
endif
enddo
! send my data to my pararent I/O node
mtype = nid
call crecv(mtype,idum,4) ! hand-shake
call csend(mtype,buffer,leo,pid0,0) ! u4 :=: u8
endif
return
end
c-----------------------------------------------------------------------
subroutine mfo_mdatas(u,nel)
include 'SIZE'
include 'INPUT'
include 'PARALLEL'
include 'RESTART'
real u(lx1*ly1*lz1,1)
real*4 buffer(1+2*lelt)
integer e
call gsync() ! clear outstanding message queues.
nxyz = nx1*ny1*nz1
n = 2
len = 4 + 4*(n*lelt) ! recv buffer size
leo = 4 + 4*(n*nelt)
! Am I an I/O node?
if (nid.eq.pid0) then
j = 1
do e=1,nel
buffer(j+0) = vlmin(u(1,e),nxyz)
buffer(j+1) = vlmax(u(1,e),nxyz)
j = j + 2
enddo
! write out my data
nout = n*nel
#ifdef MPIIO
call byte_write_mpi(buffer,nout,-1)
#else
call byte_write(buffer,nout)
#endif
! write out the data of my childs
idum = 1
do k=pid0+1,pid1
mtype = k
call csend(mtype,idum,4,k,0) ! handshake
call crecv(mtype,buffer,len)
inelp = buffer(1)
nout = n*inelp
#ifdef MPIIO
call byte_write_mpi(buffer(2),nout,-1)
#else
call byte_write(buffer(2),nout)
#endif
enddo
else
j = 1
buffer(j) = nel
j = j + 1
do e=1,nel
buffer(j+0) = vlmin(u(1,e),nxyz)
buffer(j+1) = vlmax(u(1,e),nxyz)
j = j + 2
enddo
! send my data to my pararent I/O node
mtype = nid
call crecv(mtype,idum,4) ! hand-shake
call csend(mtype,buffer,leo,pid0,0) ! u4 :=: u8
endif
return
end
c-----------------------------------------------------------------------
subroutine mfo_outs(u,nel,mx,my,mz) ! output a scalar field
include 'SIZE'
include 'INPUT'
include 'PARALLEL'
include 'RESTART'
real u(mx,my,mz,1)
common /SCRNS/ u4(2+lxo*lxo*lxo*2*lelt)
real*4 u4
real*8 u8(1+lxo*lxo*lxo*1*lelt)
equivalence (u4,u8)
integer e
call gsync() ! clear outstanding message queues.
if(mx.gt.lxo .or. my.gt.lxo .or. mz.gt.lxo) then
if(nid.eq.0) write(6,*) 'ABORT: lxo too small'
call exitt
endif
nxyz = mx*my*mz
len = 8 + 8*(lelt*nxyz) ! recv buffer size
leo = 8 + wdsizo*(nel*nxyz)
ntot = nxyz*nel
idum = 1
if (nid.eq.pid0) then
if (wdsizo.eq.4) then ! 32-bit output
call copyx4 (u4,u,ntot)
else
call copy (u8,u,ntot)
endif
nout = wdsizo/4 * ntot
#ifdef MPIIO
call byte_write_mpi(u4,nout,-1)
#else
call byte_write(u4,nout) ! u4 :=: u8
#endif
! write out the data of my childs
idum = 1
do k=pid0+1,pid1
mtype = k
call csend(mtype,idum,4,k,0) ! handshake
call crecv(mtype,u4,len)
nout = wdsizo/4 * nxyz * u8(1)
if (wdsizo.eq.4) then
#ifdef MPIIO
call byte_write_mpi(u4(3),nout,-1)
#else
call byte_write(u4(3),nout)
#endif
else
#ifdef MPIIO
call byte_write_mpi(u8(2),nout,-1)
#else
call byte_write(u8(2),nout)
#endif
endif
enddo
else
u8(1)= nel
if (wdsizo.eq.4) then ! 32-bit output
call copyx4 (u4(3),u,ntot)
else
call copy (u8(2),u,ntot)
endif
mtype = nid
call crecv(mtype,idum,4) ! hand-shake
call csend(mtype,u4,leo,pid0,0) ! u4 :=: u8
endif
return
end
c-----------------------------------------------------------------------
subroutine mfo_outv(u,v,w,nel,mx,my,mz) ! output a vector field
include 'SIZE'
include 'INPUT'
include 'PARALLEL'
include 'RESTART'
real u(mx*my*mz,1),v(mx*my*mz,1),w(mx*my*mz,1)
common /SCRNS/ u4(2+lxo*lxo*lxo*6*lelt)
real*4 u4
real*8 u8(1+lxo*lxo*lxo*3*lelt)
equivalence (u4,u8)
integer e
call gsync() ! clear outstanding message queues.
if(mx.gt.lxo .or. my.gt.lxo .or. mz.gt.lxo) then
if(nid.eq.0) write(6,*) 'ABORT: lxo too small'
call exitt
endif
nxyz = mx*my*mz
len = 8 + 8*(lelt*nxyz*ndim) ! recv buffer size (u4)
leo = 8 + wdsizo*(nel*nxyz*ndim)
idum = 1
if (nid.eq.pid0) then
j = 0
if (wdsizo.eq.4) then ! 32-bit output
do iel = 1,nel
call copyx4 (u4(j+1),u(1,iel),nxyz)
j = j + nxyz
call copyx4 (u4(j+1),v(1,iel),nxyz)
j = j + nxyz
if(if3d) then
call copyx4 (u4(j+1),w(1,iel),nxyz)
j = j + nxyz
endif
enddo
else
do iel = 1,nel
call copy (u8(j+1),u(1,iel),nxyz)
j = j + nxyz
call copy (u8(j+1),v(1,iel),nxyz)
j = j + nxyz
if(if3d) then
call copy (u8(j+1),w(1,iel),nxyz)
j = j + nxyz
endif
enddo
endif
nout = wdsizo/4 * ndim*nel * nxyz
#ifdef MPIIO
call byte_write_mpi(u4,nout,-1)
#else
call byte_write(u4,nout) ! u4 :=: u8
#endif
! write out the data of my childs
do k=pid0+1,pid1
mtype = k
call csend(mtype,idum,4,k,0) ! handshake
call crecv(mtype,u4,len)
nout = wdsizo/4 * ndim*nxyz * u8(1)
if (wdsizo.eq.4) then
#ifdef MPIIO
call byte_write_mpi(u4(3),nout,-1)
#else
call byte_write(u4(3),nout)
#endif
else
#ifdef MPIIO
call byte_write_mpi(u8(2),nout,-1)
#else
call byte_write(u8(2),nout)
#endif
endif
enddo
else
u8(1) = nel
if (wdsizo.eq.4) then ! 32-bit output
j = 2
do iel = 1,nel
call copyx4 (u4(j+1),u(1,iel),nxyz)
j = j + nxyz
call copyx4 (u4(j+1),v(1,iel),nxyz)
j = j + nxyz
if(if3d) then
call copyx4 (u4(j+1),w(1,iel),nxyz)
j = j + nxyz
endif
enddo
else
j = 1
do iel = 1,nel
call copy (u8(j+1),u(1,iel),nxyz)
j = j + nxyz
call copy (u8(j+1),v(1,iel),nxyz)
j = j + nxyz
if(if3d) then
call copy (u8(j+1),w(1,iel),nxyz)
j = j + nxyz
endif
enddo
endif
mtype = nid
call crecv(mtype,idum,4) ! hand-shake
call csend(mtype,u4,leo,pid0,0) ! u4 :=: u8
endif
return
end
c-----------------------------------------------------------------------
subroutine mfo_write_hdr ! write hdr, byte key, els.
include 'SIZE'
include 'INPUT'
include 'PARALLEL'
include 'RESTART'
include 'TSTEP'
real*4 test_pattern
common /ctmp0/ lglist(0:lelt)
character*132 hdr
integer*8 ioff
call gsync()
idum = 1
#ifdef MPIIO
nfileoo = 1 ! all data into one file
nelo = nelgt
#else
nfileoo = nfileo
if(nid.eq.pid0) then ! how many elements to dump
nelo = nelt
do j = pid0+1,pid1
mtype = j
call csend(mtype,idum,4,j,0) ! handshake
call crecv(mtype,inelp,4)
nelo = nelo + inelp
enddo
else
mtype = nid
call crecv(mtype,idum,4) ! hand-shake
call csend(mtype,nelt,4,pid0,0) ! u4 :=: u8
endif
#endif
if(nid.eq.pid0) then
call blank(hdr,132) ! write header
call blank(rdcode1,10)
i = 1
IF (IFXYO) THEN
rdcode1(i)='X'
i = i + 1
ENDIF
IF (IFVO) THEN
rdcode1(i)='U'
i = i + 1
ENDIF
IF (IFPO) THEN
rdcode1(i)='P'
i = i + 1
ENDIF
IF (IFTO) THEN
rdcode1(i)='T'
i = i + 1
ENDIF
IF (LDIMT.GT.1) THEN
NPSCALO = 0
do k = 1,ldimt-1
if(ifpsco(k)) NPSCALO = NPSCALO + 1
enddo
rdcode1(i) = 'S'
IF (NPSCALO.GT.0) THEN
WRITE(rdcode1(i+1),'(I1)') NPSCALO/10
WRITE(rdcode1(i+2),'(I1)') NPSCALO-(NPSCALO/10)*10
ENDIF
ENDIF
write(hdr,1) wdsizo,nxo,nyo,nzo,nelo,nelgt,time,istep,fid0,nfileoo
$ , (rdcode1(i),i=1,10) ! 74+20=94
1 format('#std',1x,i1,1x,i2,1x,i2,1x,i2,1x,i10,1x,i10,1x,e20.13,
& 1x,i9,1x,i6,1x,i6,1x,10a)
! if we want to switch the bytes for output
! switch it again because the hdr is in ASCII
call get_bytesw_write(ibsw_out)
c if (ibsw_out.ne.0) call set_bytesw_write(ibsw_out)
if (ibsw_out.ne.0) call set_bytesw_write(0)
test_pattern = 6.54321 ! write test pattern for byte swap
#ifdef MPIIO
! only rank0 (pid00) will write hdr + test_pattern
call byte_write_mpi(hdr,iHeaderSize/4,pid00)
call byte_write_mpi(test_pattern,1,pid00)
#else
call byte_write(hdr,iHeaderSize/4)
call byte_write(test_pattern,1)
#endif
endif
! write global element numbering for this group
if(nid.eq.pid0) then
#ifdef MPIIO
ioff = iHeaderSize + 4 + nelB*isize
call byte_set_view (ioff)
call byte_write_mpi(lglel,nelt,-1)
#else
call byte_write(lglel,nelt)
#endif
do j = pid0+1,pid1
mtype = j
call csend(mtype,idum,4,j,0) ! handshake
len = 4*(lelt+1)
call crecv(mtype,lglist,len)
#ifdef MPIIO
call byte_write_mpi(lglist(1),lglist(0),-1)
#else
call byte_write(lglist(1),lglist(0))
#endif
enddo
else
mtype = nid
call crecv(mtype,idum,4) ! hand-shake
lglist(0) = nelt
call icopy(lglist(1),lglel,nelt)
len = 4*(nelt+1)
call csend(mtype,lglist,len,pid0,0)
endif
return
end
uuuu
bdry.f: SUBROUTINE SETLOG
bdry.f:C Subroutine to initialize logical flags
bdry.f: SUBROUTINE SETRZER
bdry.f: SUBROUTINE CHKNORD (IFALGN,IFNORX,IFNORY,IFNORZ,IFC,IEL)
bdry.f: SUBROUTINE CHKAXCB
bdry.f: SUBROUTINE CHKCBC (CB,IEL,IFC,IFALGN)
bdry.f: SUBROUTINE BCMASK
bdry.f: SUBROUTINE BCDIRVC(V1,V2,V3,mask1,mask2,mask3)
bdry.f: SUBROUTINE BCDIRSC(S)
bdry.f: SUBROUTINE BCNEUSC(S,ITYPE)
bdry.f: SUBROUTINE FACEIS (CB,S,IEL,IFACE,NX,NY,NZ)
bdry.f: SUBROUTINE FACEIV (CB,V1,V2,V3,IEL,IFACE,NX,NY,NZ)
bdry.f: SUBROUTINE NEKASGN (IX,IY,IZ,IEL)
bdry.f: SUBROUTINE BCNEUTR
bdry.f: SUBROUTINE TRCON (TRX,TRY,TRZ,TR1,TR2,TR3,IEL,IFC)
bdry.f: SUBROUTINE TRST2D (TRX,TRY,SIGST,IEL,IFC)
bdry.f: SUBROUTINE TRSTAX (TRX,TRY,SIGST,IEL,IFC)
bdry.f: SUBROUTINE CTANG2D (CANG,SANG,IXN,IYN,IAN,IFC,IEL)
bdry.f: SUBROUTINE TRST3D (TRX,TRY,TRZ,SIGST,IEL,IFC)
bdry.f: SUBROUTINE SETDRS (DRM1,DRTM1,DSM1,DSTM1,IFC)
bdry.f: SUBROUTINE GLOBROT (R1,R2,R3,IEL,IFC)
bdry.f: SUBROUTINE FACEC2 (A1,A2,B1,B2,IFC)
bdry.f: SUBROUTINE LFALSE (IFA,N)
bdry.f: SUBROUTINE RZERO3 (A,B,C,N)
bdry.f: SUBROUTINE UNITVEC (X,Y,Z,N)
bdry.f: SUBROUTINE SETSHL
bdry.f: SUBROUTINE CHKZVN (VMAX,IEL,IFC,IVNORL)
bdry.f: SUBROUTINE BCTWALL (TMP1,TMP2,TMP3)
bdry.f: SUBROUTINE ANTIMSK1(X,XMASK,N)
bdry.f: subroutine check_cyclic ! check for cyclic bcs
byte_mpi.f: subroutine byte_open_mpi(fname)
byte_mpi.f: subroutine byte_read_mpi(buf,icount,iorank)
byte_mpi.f: subroutine byte_write_mpi(buf,icount,iorank)
byte_mpi.f: subroutine byte_close_mpi
byte_mpi.f: subroutine byte_set_view(ioff_in)
byte_mpi.f: subroutine nek_comm_io(nn)
calcz.f: subroutine calcz(d,e,n,dmax,dmin,z,ierr)
calcz.f: subroutine ident(a,n)
coef.f: subroutine genwz
coef.f: subroutine geom1 (xm3,ym3,zm3)
coef.f: subroutine glmapm3 (xm3,ym3,zm3)
coef.f: subroutine glmapm1
coef.f:C Note: Subroutines GLMAPM1, GEODAT1, AREA2, SETWGTR and AREA3
coef.f: subroutine geodat1
coef.f:C Note: Subroutines GLMAPM1, GEODAT1, AREA2, SETWGTR and AREA3
coef.f: subroutine geom2
coef.f: subroutine xyzrst (xrm1,yrm1,zrm1,xsm1,ysm1,zsm1,
coef.f: subroutine chkjac(jac,n,iel,X,Y,Z,ND,IERR)
coef.f: subroutine volume
coef.f: subroutine setarea
coef.f: subroutine area2
coef.f:C Note: Subroutines GLMAPM1, GEODAT1, AREA2, SETWGTR and AREA3
coef.f: subroutine setwgtr (wgtr1,wgtr2,wgtr3,wgtr4)
coef.f:C Note: Subroutines GLMAPM1, GEODAT1, AREA2, SETWGTR and AREA3
coef.f: subroutine area3
coef.f:C Note: Subroutines GLMAPM1, GEODAT1, AREA2, SETWGTR and AREA3
coef.f: subroutine lagmass
coef.f: subroutine setinvm
coef.f: subroutine maprs(y,x,xa,nrest,iel)
coef.f: subroutine map31 (y,x,iel)
coef.f: subroutine map13 (y,x,iel)
coef.f: subroutine map12 (y,x,iel)
coef.f: subroutine map21t (y,x,iel)
coef.f: subroutine map21e (y,x,iel)
coef.f: subroutine out_xyz_el(x,y,z,e)
coef.f: subroutine out_fld_el(x,e,c2)
coef.f: subroutine outxm3j(xm3,ym3,jm3)
coef.f: SUBROUTINE INVMT(A,B,AA,N)
coef.f: SUBROUTINE LUBKSB(A,N,NP,INDX,B)
coef.f: SUBROUTINE LUDCMP(A,N,NP,INDX,D)
comm_mpi.f: subroutine iniproc
comm_mpi.f: subroutine init_nek_comm
comm_mpi.f: subroutine gop( x, w, op, n)
comm_mpi.f: subroutine igop( x, w, op, n)
comm_mpi.f: subroutine i8gop( x, w, op, n)
comm_mpi.f: subroutine csend(mtype,buf,len,jnid,jpid)
comm_mpi.f: subroutine crecv(mtype,buf,lenm)
comm_mpi.f: subroutine crecv3(mtype,buf,len,lenm)
comm_mpi.f: subroutine lbcast(ifif)
comm_mpi.f: subroutine bcast(buf,len)
comm_mpi.f: subroutine create_comm(icomm)
comm_mpi.f: subroutine msgwait(imsg)
comm_mpi.f: subroutine gsync()
comm_mpi.f: subroutine exittr(stringi,rdata,idata)
comm_mpi.f: subroutine exitti(stringi,idata)
comm_mpi.f: subroutine err_chk(ierr,string)
comm_mpi.f: subroutine exitt
comm_mpi.f: subroutine printHeader
conduct.f: subroutine cdscal (igeom)
conduct.f: subroutine makeuq
conduct.f: subroutine setqvol(bql)
conduct.f: subroutine nekuq (bql,iel)
conduct.f: subroutine convab
conduct.f: subroutine makeabq
conduct.f: subroutine makebdq
conduct.f: subroutine convch_old
conduct.f: subroutine thyprk (tch,ilag)
conduct.f: subroutine thypab (tch,ilag)
conduct.f: subroutine hypmsk1 (htmask)
conduct.f: subroutine tchinit (tch,ilag)
conduct.f: subroutine lagscal
conduct.f: subroutine outfldrq (x,txt10,ichk)
conduct.f: subroutine cdscal_expl (igeom)
conduct.f: subroutine diffab ! explicit treatment of diffusion operator
connect1.f: subroutine setup_topo
connect1.f: subroutine initds
connect1.f: subroutine setedge
connect1.f: subroutine dsset(nx,ny,nz)
connect1.f: subroutine genxyzl
connect1.f: subroutine verify
connect1.f: subroutine setside
connect1.f: subroutine verrhe
connect1.f: subroutine facind (kx1,kx2,ky1,ky2,kz1,kz2,nx,ny,nz,iface)
connect1.f: subroutine facindr (kx1,kx2,ky1,ky2,kz1,kz2,nx,ny,nz,iface)
connect1.f: subroutine facev(a,ie,iface,val,nx,ny,nz)
connect1.f: subroutine ifacev(a,ie,iface,val,nx,ny,nz)
connect1.f: subroutine facec(a,b,ie,iface,nx,ny,nz,nel)
connect1.f: subroutine combin2(glnm1,glnm2,nglob)
connect1.f: subroutine outfldio (x,txt10)
connect1.f: subroutine outfldi (x,txt10)
connect1.f: subroutine outfldr (x,txt10)
connect1.f: subroutine checkit(idum)
connect1.f: subroutine outfldro (x,txt10,ichk)
connect1.f: subroutine outfldrp (x,txt10,ichk)
connect1.f: subroutine outmatp(a,m,n,name6,ie)
connect1.f: subroutine gs_chkr(glo_num)
connect1.f: subroutine gs_counter(glo_num,gsh_std)
connect1.f: subroutine gs_new_tstr(glo_num,x,c,gsh_std)
connect1.f: subroutine xfill(x,c,n)
connect1.f: subroutine setup_mesh_dssum ! Set up dssum for mesh
connect2.f: subroutine readat
connect2.f: subroutine rdparam
connect2.f: subroutine rdmesh
connect2.f: subroutine rdcurve
connect2.f: subroutine rdbdry
connect2.f: subroutine rdicdf
connect2.f: subroutine rdmatp
connect2.f: subroutine rdhist
connect2.f: subroutine rdout
connect2.f: subroutine rdobj
connect2.f: subroutine vrdsmsh
connect2.f: subroutine vrdsmshx ! verify mesh topology
connect2.f: subroutine rotat2(xyz,angle,npts)
connect2.f: subroutine scale(xyzl,nl)
connect2.f: subroutine inrtia(xyzi,cg,xyzl,n,itype)
connect2.f: subroutine volume2(vol,xyz,n)
connect2.f: subroutine findcg(cg,xyz,n)
connect2.f: subroutine divide(list1,list2,nl1,nl2,ifok,list,nl,xyzi,cg,WGT)
connect2.f: subroutine bin_rd1(ifbswap) ! read mesh, curve, and bc info
connect2.f: subroutine buf_to_xyz(buf,e,ifbswap) ! version 1 of binary reader
connect2.f: subroutine buf_to_curve(buf) ! version 1 of binary reader
connect2.f: subroutine buf_to_bc(cbl,bl,buf) ! version 1 of binary reader
connect2.f: subroutine bin_rd1_mesh(ifbswap) ! version 1 of binary reader
connect2.f: subroutine bin_rd1_curve (ifbswap) ! v. 1 of curve side reader
connect2.f: subroutine bin_rd1_bc (cbl,bl,ifbswap) ! v. 1 of bc reader
connect2.f: subroutine buf_close_outv ! this is the stupid O(P) formulation
connect2.f: subroutine buf_close_out ! this is the stupid O(P) formulation
connect2.f: subroutine open_bin_file(ifbswap) ! open file & chk for byteswap
connect2.f: subroutine chk_xyz
connect2.f: subroutine chk_nel
connect2.f: subroutine cscan(sout,key,nk)
convect.f: subroutine setup_convect(igeom)
convect.f: subroutine char_conv(p0,u,ulag,msk,c,cs,gsl)
convect.f: subroutine char_conv1
convect.f: subroutine int_vel(c_t,t0,c,n,nc,ct,nid)
convect.f: subroutine conv_rhs (du,u,c,bmsk,gsl)
convect.f: subroutine convop_fst_3d(du,u,c,mx,md,nel)
convect.f: subroutine convop_fst_2d(du,u,c,mx,md,nel)
convect.f: subroutine grad_rstd(ur,us,ut,u,mx,md,if3d,ju)
convect.f: subroutine intp_rstd(ju,u,mx,md,if3d,idir)
convect.f: subroutine gen_int(jgl,jgt,mp,np,w)
convect.f: subroutine gen_dgl(dgl,dgt,mp,np,w)
convect.f: subroutine lim_chk(n,m,avar5,lvar5,sub_name10)
convect.f: subroutine get_int_ptr (ip,mx,md)
convect.f: subroutine get_dgl_ptr (ip,mx,md)
convect.f: subroutine set_conv_char(ct,c,ux,uy,uz,nelc,tau,ifnew)
convect.f: subroutine set_ct_cvx(ct,c,m,u,v,w,tau,nc,mc,nelc,ifnew)
convect.f: subroutine grad_rst(ur,us,ut,u,md,if3d)
convect.f: subroutine convect_new(bdu,u,ifuf,cx,cy,cz,ifcf)
convect.f: subroutine convect_cons(bdu,u,ifuf,cx,cy,cz,ifcf)
convect.f: subroutine set_convect_cons(cx,cy,cz,ux,uy,uz)
convect.f: subroutine set_convect_new(cr,cs,ct,ux,uy,uz)
convect.f: subroutine set_char_mask(mask,u,v,w) ! mask for hyperbolic system
convect.f: subroutine advchar
convect.f: subroutine convch
convect.f: subroutine convop_cons_3d(du,u,c,mx,md,nel) ! Conservation form
convect.f: subroutine convop_cons_2d(du,u,c,mx,md,nel) ! Conservation form
cvode_aux.f: subroutine add_fcvfun_usr(ydot)
cvode_aux.f: subroutine cv_unpack_sol(y)
cvode_aux.f: subroutine cv_pack_sol(y)
cvode_driver.f: subroutine cv_setsize(n_in,nfld_last)
cvode_driver.f: subroutine cv_init
cvode_driver.f: subroutine cdscal_cvode(igeom)
cvode_driver.f: subroutine cv_setsize(n_in,nfld_last)
cvode_driver.f: subroutine cv_init
cvode_driver.f: subroutine cdscal_cvode(igeom)
cvode_driver.f: SUBROUTINE FCVJTIMES (V,FJV,TT,Y,FY,H,IPAR,RPAR,WORK,IER)
cvode_driver.f: subroutine store_vel(vx_,vy_,vz_)
cvode_driver.f: subroutine set_vel(vx_,vy_,vz_)
cvode_driver.f: subroutine update_vel(time_)
cvode_driver.f: subroutine fcvfun (cv_time, y, ydot, ipar, rpar, ier)
drive1.f: subroutine nek_init
drive1.f: subroutine nek_solve
drive1.f: subroutine nek_advance
drive1.f: subroutine nek_end
drive2.f: subroutine initdim
drive2.f: subroutine initdat
drive2.f: subroutine comment
drive2.f: subroutine setvar
drive2.f: subroutine echopar
drive2.f: subroutine gengeom (igeom)
drive2.f: subroutine files
drive2.f: subroutine settime
drive2.f: subroutine geneig (igeom)
drive2.f: subroutine fluid (igeom)
drive2.f: subroutine heat (igeom)
drive2.f: subroutine meshv (igeom)
drive2.f: subroutine rescont (ind)
drive2.f: subroutine rstartc (ind)
drive2.f: subroutine time00
drive2.f: subroutine runstat
drive2.f: subroutine pprint_all(s,n_in,io)
drive2.f: subroutine opcount(ICALL)
drive2.f: subroutine dofcnt
drive2.f: subroutine vol_flow
drive2.f: subroutine compute_vol_soln(vxc,vyc,vzc,prc)
drive2.f: subroutine plan2_vol(vxc,vyc,vzc,prc)
drive2.f: subroutine plan3_vol(vxc,vyc,vzc,prc)
drive2.f: subroutine a_dmp
drive2.f: subroutine outrio (v,n,io)
drive2.f: subroutine reset_prop
dssum.f: subroutine setupds(gs_handle,nx,ny,nz,nel,melg,vertex,glo_num)
dssum.f: subroutine dssum(u,nx,ny,nz)
dssum.f: subroutine dsop(u,op,nx,ny,nz)
dssum.f: subroutine vec_dssum(u,v,w,nx,ny,nz)
dssum.f: subroutine vec_dsop(u,v,w,nx,ny,nz,op)
dssum.f: subroutine nvec_dssum(u,stride,n,gs_handle)
dssum.f: subroutine matvec3(uout,Jmat,uin,iftrsp,n1,n2)
dssum.f: subroutine matvec3t(uout,Jmat,uin,iftrsp,n1,n2)
dssum.f: subroutine matvect (out,d,vec,n1,n2)
dssum.f:c subroutine opq_in_place(a,b,c)
dssum.f: subroutine vectof_add(b,a,ie,iface,nx,ny,nz)
dssum.f: subroutine zero_f(b,ie,iface,nx,ny,nz)
dssum.f: subroutine ftovec_0(a,b,ie,iface,nx,ny,nz)
dssum.f: subroutine ftovec(a,b,ie,iface,nx,ny,nz)
dssum.f: subroutine vectof(b,a,ie,iface,nx,ny,nz)
dssum.f: subroutine ftoveci(a,b,ie,iface,nx,ny,nz)
dssum.f: subroutine vectofi(b,a,ie,iface,nx,ny,nz)
dssum.f: subroutine apply_Jt(u,nx,ny,nz,nel)
dssum.f: subroutine apply_J(u,nx,ny,nz,nel)
dssum.f: subroutine h1_proj(u,nx,ny,nz)
dssum.f: subroutine dssum_msk(u,mask,nx,ny,nz)
dssum.f: subroutine dssum_msk2(u,mask,binv,nx,ny,nz)
eigsolv.f: SUBROUTINE ESTEIG
eigsolv.f: SUBROUTINE EIGENV
eigsolv.f: SUBROUTINE ALPHAM1 (ALPHA,MASK,MULT,H1,H2,ISD)
eigsolv.f: SUBROUTINE GAMMAM1 (GAMMA,MASK,MULT,H1,H2,ISD)
eigsolv.f: SUBROUTINE ALPHAM2 (ALPHA,H1,H2,H2INV,INLOC)
eigsolv.f: SUBROUTINE GAMMAM2 (GAMMA,H1,H2,H2INV,INLOC)
eigsolv.f: SUBROUTINE STARTX1 (X1,Y1,MASK,MULT,NEL)
eigsolv.f: SUBROUTINE STARTX2 (X2,Y2)
fast3d.f: subroutine gen_fast(x,y,z)
fast3d.f: subroutine plane_space_std(lr,ls,lt,i1,i2,w,x,y,z,nx,nxn,nz0,nzn)
fast3d.f: subroutine plane_space(lr,ls,lt,i1,i2,w,x,y,z,nx,nxn,nz0,nzn)
fast3d.f: subroutine plane_space2(lr,ls,lt,i1,w,x,y,z,nx,nxn,nz0,nzn)
fast3d.f: subroutine set_up_fast_1D_fem(s,lam,n,lbc,rbc,ll,lm,lr,z,nz,ie)
fast3d.f: subroutine set_up_1D_geom(dx,lbc,rbc,ll,lm,lr,z,nz)
fast3d.f: subroutine gen_eigs_A_fem(sf,sft,atd,n,l,lbc,rbc)
fast3d.f: subroutine get_fast_bc(lbr,rbr,lbs,rbs,lbt,rbt,ie,ierr)
fast3d.f: subroutine get_fast_bc2(lbr,rbr,lbs,rbs,lbt,rbt,ie,ierr)
fast3d.f: subroutine outv(x,n,name3)
fast3d.f: subroutine outmat(a,m,n,name6,ie)
fast3d.f: subroutine set_up_fast_1D_fem_ax
fast3d.f: subroutine set_up_1D_geom_ax(dx,lbc,rbc,ll,lm,lr,z,y,nz)
fast3d.f: subroutine gen_eigs_A_fem_ax(sf,sft,atd,n,l,y,lbc,rbc)
fast3d.f: subroutine load_semhat_weighted ! Fills the SEMHAT arrays
fast3d.f: subroutine do_semhat_weight(jgl,dgl,bgl,n)
fast3d.f: subroutine semhat(a,b,c,d,z,dgll,jgll,bgl,zgl,dgl,jgl,n,w)
fast3d.f: subroutine fd_weights_full(xx,x,n,m,c)
fast3d.f: subroutine set_up_fast_1D_sem(s,lam,n,lbc,rbc,ll,lm,lr,ie)
fast3d.f: subroutine set_up_fast_1D_sem_op(g,b0,b1,l,r,ll,lm,lr,bh,jgl,jscl)
fast3d.f: subroutine swap_lengths
fast3d.f: subroutine row_zero(a,m,n,i)
fasts.f: subroutine local_solves_fdm(u,v)
fasts.f: subroutine fastdm1(R,ie,w1,w2)
fasts.f: subroutine tensr3(v,nv,u,nu,A,Bt,Ct,w)
fasts.f: subroutine s_face_to_int(x,c)
fasts.f: subroutine dface_ext(x)
fasts.f: subroutine dface_add1si(x,c)
fasts.f: subroutine init_weight_op
fasts.f: subroutine do_weight_op(x)
gauss.f: SUBROUTINE LU(A,N,NDIM,IR,IC)
gauss.f:C IT IS THE FIRST SUBROUTINE TO COMPUTE THE MX. INV.
gauss.f: SUBROUTINE SOLVE(F,A,K,N,NDIM,IR,IC)
genbox.f: subroutine genbox
genbox.f: subroutine gen_gtp_vertex (vertex,ncrnr)
genbox.f: subroutine getbox(x,y,z,nfld)
genbox.f: subroutine mapbox(melx,mely,melz)
genbox.f: subroutine makebox(x,y,z,nfld)
genbox.f: subroutine geti1(i,iend,io)
genbox.f: subroutine geti2(i1,i2,iend,io)
genbox.f: subroutine geti3(i1,i2,i3,iend,io)
genbox.f: subroutine getr2(r1,r2,iend,io)
genbox.f: subroutine getr3(r1,r2,r3,iend,io)
genbox.f: subroutine getrv(r,n,iend,io)
genbox.f: subroutine getiv(r,n,iend,io)
genbox.f: subroutine getcv0(c,m,n,iend,io)
genbox.f: subroutine getcv(c,m,n,iend,io)
genbox.f: subroutine gets(c,n,iend,io)
genbox.f: subroutine get_multi_seg(nelxyz,x,y,z,m,if3d)
genbox.f: subroutine geometric_x(x,n,x0,x1,gain)
genbox.f: subroutine get_xyz_distribution (x,nelx)
genbox.f: subroutine scannocom(iend,infile)
genbox.f: subroutine jjnt(x,n)
genbox.f: subroutine bcpbox(nfld)
genbox.f: subroutine outbox_mesh
genxyz.f: subroutine arcsrf(xml,yml,zml,nxl,nyl,nzl,ie,isid)
genxyz.f: subroutine defsrf(xml,yml,zml,nxl,nyl,nzl,ie,iface1,ccv)
genxyz.f: subroutine intrsc(x3,x2,x1,delt,ie,iface)
genxyz.f: subroutine zbrac(x1,x2,succes)
genxyz.f: subroutine setdef
genxyz.f: subroutine gencoor (xm3,ym3,zm3)
genxyz.f: subroutine genxyz (xml,yml,zml,nxl,nyl,nzl)
genxyz.f: subroutine setzgml (zgml,iel,nxl,nyl,nzl,ifaxis)
genxyz.f: subroutine sphsrf(xml,yml,zml,ifce,ie,nx,ny,nz,xysrf)
genxyz.f: subroutine edg3d(xysrf,x1,x2,i1,i2,j1,j2,nx,ny)
genxyz.f: subroutine cross(v1,v2,v3)
genxyz.f: subroutine norm3d(v1)
genxyz.f: subroutine crn3d(xcv,xc,yc,zc,curve,iface)
genxyz.f: subroutine rotxyz
genxyz.f: subroutine gensrf(XML,YML,ZML,IFCE,IE,MX,MY,MZ,zgml)
genxyz.f: subroutine prjects(x0,dxc,c,cc)
genxyz.f: subroutine srfind(x1,x0,c,cc)
genxyz.f: subroutine linquad(xl,yl,zl,nxl,nyl,nzl)
genxyz.f: subroutine xyzlin(xl,yl,zl,nxl,nyl,nzl,e)
genxyz.f: subroutine xyzquad(xl,yl,zl,nxl,nyl,nzl,e)
gfdm_op.f: subroutine gfdm_ops
gfdm_op.f: subroutine gfdm_set_prs_op(mfld)
gfdm_op.f: subroutine set_1d_e_mat(eigv,eigs,n,length,nel,nxv,nxp
gfdm_op.f: subroutine build_D1d_d(DI,II,dgg1,igg1,wm1,b1d,length,nel,nxv,nxp
gfdm_op.f: subroutine gfdm_set_diagp(eigi,tpn,nn,eigx,l,eigy,m,eigz,n)
gfdm_op.f: subroutine gfdm_set_geom(work,melx,mely,melz)
gfdm_op.f: subroutine gfdm_set_genwz(nx,nxp)
gfdm_op.f: subroutine gfdm_set_bc(cb0,cbn,mfld)
gfdm_op.f: subroutine add2s2mat2p(a,ma,na,i1,j1,b,ldb,s,m,n)
gfdm_op.f: subroutine overflow_chk(n_req,n_avail,var,sub)
gfdm_op.f: subroutine solveMp(z,r,n,w,nza)
gfdm_op.f: subroutine map12q(r2,r1,rt)
gfdm_op.f: subroutine cgpa(x,b,r,p,z,w,niter,tolin)
gfdm_op.f: subroutine row_mult (A,B,n1,n2)
gfdm_op.f: subroutine a1d (A1,A1t,d2,b2,d1,d1t,wgl,nx)
gfdm_op.f: subroutine set_diagA (da,dat,b,d,w,nx)
gfdm_op.f: subroutine gfdm_chk_size
gfdm_par.f: subroutine g25d_init
gfdm_par.f: subroutine gfdm_init
gfdm_par.f: subroutine gfdm_check_array_sizes
gfdm_par.f: subroutine gfdm_mappings
gfdm_par.f: subroutine assign_tp_numbering_pres(tpn,nex,ney,nez,nx,ny,nz
gfdm_par.f: subroutine reassign_tp_numbering
gfdm_par.f: subroutine cex_setup(part_in,nr,part_out,m,n,nid,np)
gfdm_par.f: subroutine cexr(w,u,m,n,part_out,part_in,msg_id,wdsize,nid,np)
gfdm_par.f: subroutine cextr(u,m,n,w,part_out,part_in,msg_id,wdsize,nid,np)
gfdm_par.f: subroutine cexi(w,u,m,n,part_out,part_in,msg_id,wdsize,nid,np)
gfdm_par.f: subroutine cexti(u,m,n,w,part_out,part_in,msg_id,wdsize,nid,np)
gfdm_solve.f: subroutine gfdm_pres_solv(z,r,ug,wg)
gmres.f: subroutine uzawa_gmres(res,h1,h2,h2inv,intype,iter)
gmres.f: subroutine uzawa_gmres_split0(l,u,b,binv,n)
gmres.f: subroutine uzawa_gmres_split(l,u,b,binv,n)
gmres.f: subroutine uzawa_gmres_temp(a,b,n)
gmres.f: subroutine ax(w,x,h1,h2,n)
gmres.f: subroutine hmh_gmres(res,h1,h2,wt,iter)
gmres.f: subroutine set_overlap2
gmres.f: subroutine h1_overlap_2(u,v,mask)
gmres.f: subroutine dd_swap_vals(v1,v0,gsh_dd)
gmres.f: subroutine gen_fast_g
gmres.f: subroutine set_up_fast_1D_sem_g(s,lam,n,lbc,rbc,ll,lm,lr,ie)
gmres.f: subroutine set_up_fast_1D_sem_op_a(g,b0,b1,l
gmres.f: subroutine set_up_fast_1D_sem_op_b(g,b0,b1,l
gmres.f: subroutine fill_interior_g(v1,v,e,nx,nz,iz1,nel)
gmres.f: subroutine dface_ext_g(x,t,e,nx,nz)
gmres.f: subroutine dface_add1si_g(x,c,t,e,nx,nz)
gmres.f: subroutine fastdm1_g(R,ie,w1,w2)
gmres.f: subroutine s_face_to_int2_g(x,c,t,e,nx,nz)
gmres.f: subroutine outfldr_g(x,txt10,nx,nz,ichk)
gmres.f: subroutine outfldi_g(x,txt10,nx,nz,ichk)
gmres.f: subroutine setupds_no_crn(gs_h,nx,ny,nz,nel,melg,vertex,glo_num)
gmres.f: subroutine rzero_g(a,e,nx,ny,nz)
hmholtz.f: subroutine hmholtz(name,u,rhs,h1,h2,mask,mult,imsh,tli,maxit,isd)
hmholtz.f: subroutine axhelm (au,u,helm1,helm2,imesh,isd)
hmholtz.f: subroutine setfast (helm1,helm2,imesh)
hmholtz.f: subroutine sfastax
hmholtz.f: subroutine setprec (dpcm1,helm1,helm2,imesh,isd)
hmholtz.f: subroutine chktcg1 (tol,res,h1,h2,mask,mult,imesh,isd)
hmholtz.f: subroutine cggo(x,f,h1,h2,mask,mult,imsh,tin,maxit,isd,binv,name)
hmholtz.f: subroutine calc (diag,upper,d,e,n,dmax,dmin)
hmholtz.f: subroutine fdm_h1(z,r,d,mask,mult,nel,kt,rr)
hmholtz.f: subroutine set_fdm_prec_h1A_gen
hmholtz.f: subroutine set_fdm_prec_h1A_els
hmholtz.f: subroutine set_fdm_prec_h1b(d,h1,h2,nel)
hmholtz.f: subroutine set_fdm_prec_h1A
hmholtz.f: subroutine generalev(a,b,lam,n,w)
hmholtz.f: subroutine outmat2(a,m,n,k,name)
hmholtz.f: subroutine rescale_abhalf (a,b,w,n)
hsmg.f: subroutine hsmg_setup()
hsmg.f: subroutine hsmg_setup_semhat
hsmg.f: subroutine hsmg_setup_intp
hsmg.f: subroutine hsmg_setup_intpm(jh,zf,zc,nf,nc)
hsmg.f: subroutine hsmg_setup_dssum
hsmg.f: subroutine hsmg_setup_wtmask
hsmg.f: subroutine hsmg_intp(uf,uc,l) ! l is coarse level
hsmg.f: subroutine hsmg_rstr(uc,uf,l) ! l is coarse level
hsmg.f: subroutine hsmg_rstr_no_dssum(uc,uf,l) ! l is coarse level
hsmg.f: subroutine hsmg_tnsr(v,nv,u,nu,A,At)
hsmg.f: subroutine hsmg_tnsr2d(v,nv,u,nu,A,Bt)
hsmg.f: subroutine hsmg_tnsr3d(v,nv,u,nu,A,Bt,Ct)
hsmg.f: subroutine hsmg_tnsr2d_el(v,nv,u,nu,A,Bt)
hsmg.f: subroutine hsmg_tnsr3d_el(v,nv,u,nu,A,Bt,Ct)
hsmg.f: subroutine hsmg_dssum(u,l)
hsmg.f: subroutine hsmg_dsprod(u,l)
hsmg.f: subroutine hsmg_schwarz_dssum(u,l)
hsmg.f: subroutine hsmg_extrude(arr1,l1,f1,arr2,l2,f2,nx,ny,nz)
hsmg.f: subroutine hsmg_schwarz(e,r,l)
hsmg.f: subroutine hsmg_schwarz_toext2d(a,b,n)
hsmg.f: subroutine hsmg_schwarz_toext3d(a,b,n)
hsmg.f: subroutine hsmg_schwarz_toreg2d(b,a,n)
hsmg.f: subroutine hsmg_schwarz_toreg3d(b,a,n)
hsmg.f: subroutine hsmg_setup_fdm()
hsmg.f: subroutine hsmg_setup_fast(s,d,nl,ah,bh,n)
hsmg.f: subroutine hsmg_setup_fast1d(s,lam,nl,lbc,rbc,ll,lm,lr,ah,bh,n,ie)
hsmg.f: subroutine hsmg_setup_fast1d_a(a,lbc,rbc,ll,lm,lr,ah,n)
hsmg.f: subroutine hsmg_setup_fast1d_b(b,lbc,rbc,ll,lm,lr,bh,n)
hsmg.f: subroutine hsmg_fdm(e,r,l)
hsmg.f: subroutine hsmg_do_fast(e,r,s,d,nl)
hsmg.f: subroutine hsmg_do_wt(u,wt,nx,ny,nz)
hsmg.f: subroutine hsmg_setup_rstr_wt(wt,nx,ny,nz,l,w)
hsmg.f: subroutine hsmg_setup_mask(wt,nx,ny,nz,l,w)
hsmg.f: subroutine hsmg_setup_schwarz_wt(ifsqrt)
hsmg.f: subroutine hsmg_setup_schwarz_wt2d(wt,n,work,ifsqrt)
hsmg.f: subroutine hsmg_setup_schwarz_wt3d(wt,n,work,ifsqrt)
hsmg.f: subroutine hsmg_schwarz_wt(e,l)
hsmg.f: subroutine hsmg_schwarz_wt2d(e,wt,n)
hsmg.f: subroutine hsmg_schwarz_wt3d(e,wt,n)
hsmg.f: subroutine hsmg_coarse_solve(e,r)
hsmg.f: subroutine hsmg_setup_solve
hsmg.f: subroutine hsmg_solve(e,r)
hsmg.f: subroutine hsmg_setup_mg_nx()
ic.f: subroutine setics
ic.f:c mesh coordinates (see Subroutine INIGEOM)
ic.f: subroutine slogic (iffort,ifrest,ifprsl,nfiles)
ic.f: subroutine restart(nfiles)
ic.f: subroutine sioflag(ndumps,fname,rsopts)
ic.f: subroutine mapdmp(sdump,tdump,ieg,nxr,nyr,nzr,if_byte_sw)
ic.f: subroutine mapab(x,y,nxr,nel)
ic.f: subroutine mapab4R(x,y,nxr,nel)
ic.f: subroutine csplit(s0,s1,s2,l0)
ic.f: subroutine lshft(string,ipt)
ic.f: subroutine ljust(string)
ic.f: subroutine chknorm (ifzero)
ic.f: subroutine prsolvt
ic.f: subroutine prsolvv
ic.f: subroutine nekuic
ic.f: subroutine capit(lettrs,n)
ic.f: subroutine perturb(tt,ifld,eps)
ic.f: subroutine vcospf(x,y,n)
ic.f: subroutine vbyte_swap(x,n)
ic.f: subroutine geom_reset(icall)
ic.f: subroutine dsavg(u)
ic.f: subroutine map13_all(x3,x1)
ic.f: subroutine mfi_gets(u,wk,lwk,iskip)
ic.f: subroutine mfi_getv(u,v,w,wk,lwk,iskip)
ic.f: subroutine mfi_parse_hdr(hdr)
ic.f: subroutine parse_std_hdr(hdr)
ic.f: subroutine parse_std_hdr_2006(hdr,rlcode)
ic.f: subroutine mfi(fname)
ic.f: subroutine mbyte_open(hname,fid) ! open blah000.fldnn
ic.f: subroutine mfi_prepare(hname) ! determine which nodes are readers
induct.f: subroutine induct (igeom)
induct.f: subroutine lagbfield
induct.f: subroutine makebsource_mhd
induct.f: subroutine makeufb
induct.f: subroutine makextb
induct.f: subroutine makebdfb
induct.f: subroutine cresvib(resv1,resv2,resv3,h1,h2)
induct.f: subroutine cresvibp(resv1,resv2,resv3,h1,h2)
induct.f: subroutine incomprn (ux,uy,uz,up)
induct.f: subroutine opzero(ux,uy,uz)
induct.f: subroutine opnorm(unorm,ux,uy,uz,type3)
induct.f: subroutine lorentz_force (lf,b1,b2,b3,w1,w2)
induct.f: subroutine curl(vort,u,v,w,ifavg,work1,work2)
induct.f: subroutine lorentz_force2(lf,b1,b2,b3)
induct.f: subroutine lorentz_force_e(lf,b1,b2,b3,e)
induct.f: subroutine spec_curl_e (cb,b1,b2,b3,rx,ry,rz,sx,sy,sz,tx,ty,tz)
induct.f: subroutine specx(b,nb,a,na,ba,ab,w)
induct.f: subroutine phys_to_elsasser(u1,u2,u3,b1,b2,b3,n)
induct.f: subroutine elsasser_to_phys(u1,u2,u3,b1,b2,b3,n)
induct.f: subroutine phys_to_elsasser2(u1,b1,n)
induct.f: subroutine elsasser_to_phys2(u1,b1,n)
induct.f: subroutine elsasserh(igeom)
induct.f: subroutine compute_cfl(cfl,u,v,w,dt)
induct.f: subroutine getdr(dri,zgm1,nx1)
induct.f: subroutine ophinv_pr(o1,o2,o3,i1,i2,i3,h1,h2,tolh,nmxhi)
induct.f: subroutine ophinvm(o1,o2,o3,i1,i2,i3,m1,m2,m3,h1,h2,tolh,nmxhi)
induct.f: subroutine set_ifbcor(ifbcor)
induct.f: subroutine setrhsp(p,h1,h2,h2inv,pset,nprev)
induct.f: subroutine gensolnp(p,h1,h2,h2inv,pset,nprev)
induct.f: subroutine econjp(pset,nprev,h1,h2,h2inv,ierr)
induct.f: subroutine advab_elsasser_fast
induct.f: subroutine set_dealias_rx
induct.f: subroutine cfl_check
init_plugin.f: subroutine init_plugin
makeq.f: subroutine makeq
makeq_aux.f: subroutine makeq_aux
map2.f: subroutine mapelpr()
map2.f: subroutine set_proc_map()
map2.f: subroutine gfdm_elm_to_proc(gllnid,np)
map2.f: subroutine gfdm_map_2d(map_st,nes,net,num_el,np)
map2.f: subroutine gfdm_set_pst(ip,is,it,nelbox,nstride_box,nxp,nyp,nzp)
map2.f: subroutine gfdm_build_global_el_map (gllnid,map_st,nes,net
map2.f: subroutine outmati(u,m,n,name6)
map2.f: subroutine get_map
math.f: SUBROUTINE BLANK(A,N)
math.f: SUBROUTINE VSQ (A,N)
math.f: SUBROUTINE VSQRT(A,N)
math.f: subroutine invers2(a,b,n)
math.f: subroutine invcol1(a,n)
math.f: subroutine invcol2(a,b,n)
math.f: subroutine invcol3(a,b,c,n)
math.f: subroutine col4(a,b,c,d,n)
math.f: subroutine Xaddcol3(a,b,c,n)
math.f: subroutine addcol4(a,b,c,d,n)
math.f: subroutine ascol5 (a,b,c,d,e,n)
math.f: subroutine sub2(a,b,n)
math.f: subroutine sub3(a,b,c,n)
math.f: subroutine subcol3(a,b,c,n)
math.f: subroutine subcol4(a,b,c,d,n)
math.f: subroutine rzero(a,n)
math.f: subroutine izero(a,n)
math.f: subroutine ione(a,n)
math.f: subroutine rone(a,n)
math.f: subroutine cfill(a,b,n)
math.f: subroutine ifill(ia,ib,n)
math.f: subroutine copy(a,b,n)
math.f: subroutine chcopy(a,b,n)
math.f: subroutine icopy(a,b,n)
math.f: subroutine i8copy(a,b,n)
math.f: subroutine chsign(a,n)
math.f: subroutine cmult(a,const,n)
math.f: subroutine cadd(a,const,n)
math.f: subroutine iadd(i1,iscal,n)
math.f: subroutine cadd2(a,b,const,n)
math.f: subroutine vcross (u1,u2,u3,v1,v2,v3,w1,w2,w3,n)
math.f: subroutine vdot2 (dot,u1,u2,v1,v2,n)
math.f: subroutine vdot3 (dot,u1,u2,u3,v1,v2,v3,n)
math.f: subroutine addtnsr(s,h1,h2,h3,nx,ny,nz)
math.f: subroutine iflip(i1,n)
math.f: subroutine iswap(b,ind,n,temp)
math.f: subroutine col2(a,b,n)
math.f: subroutine col2c(a,b,c,n)
math.f: subroutine col3(a,b,c,n)
math.f: subroutine add2(a,b,n)
math.f: subroutine add3(a,b,c,n)
math.f: subroutine addcol3(a,b,c,n)
math.f: subroutine add2s1(a,b,c1,n)
math.f: subroutine add2s2(a,b,c1,n)
math.f: subroutine add3s2(a,b,c,c1,c2,n)
math.f: subroutine add4(a,b,c,d,n)
math.f: subroutine gllog(la,lb)
math.f: subroutine dcadd(a,const,n)
math.f: subroutine dsub2(a,b,n)
math.f: subroutine dadd2(a,b,n)
math.f: subroutine chswapr(b,L,ind,n,temp)
math.f: subroutine drcopy(r,d,N)
math.f: subroutine sorts(xout,xin,work,n)
math.f: subroutine icadd(a,c,n)
math.f: subroutine isort(a,ind,n)
math.f: subroutine sort(a,ind,n)
math.f: subroutine iswap_ip(x,p,n)
math.f: subroutine iswapt_ip(x,p,n)
math.f: subroutine swap_ip(x,p,n)
math.f: subroutine swapt_ip(x,p,n)
math.f: subroutine glvadd(x,w,n)
math.f: subroutine add3s12(x,y,z,c1,c2,n)
math.f: subroutine admcol3(a,b,c,d,n)
math.f: subroutine add2col2(a,b,c,n)
math.f: subroutine add2sxy(x,a,y,b,n)
math.f: subroutine col2s2(x,y,s,n)
mpi_dummy.f: subroutine mpi_scan(data1, data2, n, datatype,
mpi_dummy.f: subroutine mpi_abort ( comm, errorcode, ierror )
mpi_dummy.f: subroutine mpi_allgather ( data1, nsend, sendtype, data2,
mpi_dummy.f: subroutine mpi_allgatherv ( data1, nsend, sendtype,
mpi_dummy.f: subroutine mpi_allreduce ( data1, data2, n, datatype,
mpi_dummy.f: subroutine mpi_barrier ( comm, ierror )
mpi_dummy.f: subroutine mpi_bcast ( data, n, datatype, node, comm, ierror )
mpi_dummy.f: subroutine mpi_bsend ( data, n, datatype, iproc, itag,
mpi_dummy.f: subroutine mpi_cart_create ( comm, ndims, dims, periods,
mpi_dummy.f: subroutine mpi_cart_get ( comm, ndims, dims, periods,
mpi_dummy.f: subroutine mpi_cart_shift ( comm, idir, idisp, isource,
mpi_dummy.f: subroutine mpi_comm_dup ( comm, comm_out, ierror )
mpi_dummy.f: subroutine mpi_comm_free ( comm, ierror )
mpi_dummy.f: subroutine mpi_comm_rank ( comm, me, ierror )
mpi_dummy.f: subroutine mpi_comm_size ( comm, nprocs, ierror )
mpi_dummy.f: subroutine mpi_comm_split ( comm, icolor, ikey, comm_new,
mpi_dummy.f: subroutine mpi_copy_double_precision ( data1, data2, n, ierror )
mpi_dummy.f: subroutine mpi_copy_integer ( data1, data2, n, ierror )
mpi_dummy.f: subroutine mpi_copy_real ( data1, data2, n, ierror )
mpi_dummy.f: subroutine mpi_finalize ( ierror )
mpi_dummy.f: subroutine mpi_get_count ( istatus, datatype, icount, ierror )
mpi_dummy.f: subroutine mpi_init ( ierror )
mpi_dummy.f: subroutine mpi_irecv ( data, n, datatype, iproc, itag,
mpi_dummy.f: subroutine mpi_isend ( data, n, datatype, iproc, itag,
mpi_dummy.f: subroutine mpi_recv ( data, n, datatype, iproc, itag,
mpi_dummy.f: subroutine mpi_reduce ( data1, data2, n, datatype, operation,
mpi_dummy.f: subroutine mpi_reduce_double_precision (
mpi_dummy.f: subroutine mpi_reduce_integer8 (
mpi_dummy.f: subroutine mpi_reduce_integer (
mpi_dummy.f: subroutine mpi_reduce_real (
mpi_dummy.f: subroutine mpi_reduce_scatter ( data1, data2, n, datatype,
mpi_dummy.f: subroutine mpi_rsend ( data, n, datatype, iproc, itag,
mpi_dummy.f: subroutine mpi_send ( data, n, datatype, iproc, itag,
mpi_dummy.f: subroutine mpi_wait ( irequest, istatus, ierror )
mpi_dummy.f: subroutine mpi_waitall ( icount, irequest, istatus, ierror )
mpi_dummy.f: subroutine mpi_waitany ( icount, array_of_requests, index,
mpi_dummy.f: subroutine mpi_initialized(mpi_is_initialized, ierr)
mpi_dummy.f: subroutine mpi_comm_create(icomm,igroup,icommd,ierr)
mpi_dummy.f: subroutine mpi_comm_group(icomm,igroup,ierr)
mpi_dummy.f: subroutine mpi_group_free
mpi_dummy.f: subroutine mpi_attr_get(icomm,ikey,ival,iflag,ierr)
mvmesh.f: subroutine cbcmesh
mvmesh.f: subroutine admeshv
mvmesh.f: subroutine admesht
mvmesh.f: subroutine divws (fms,sfv,phi,nel,idir)
mvmesh.f: subroutine axifms (fms,sfv,phi,nel,idir)
mvmesh.f: subroutine updcoor
mvmesh.f:C Subroutine to update geometry for moving boundary problems
mvmesh.f: subroutine mvbdry (nel)
mvmesh.f: subroutine norcmp (wt1,wt2,wt3,rnx,rny,rnz,ifc)
mvmesh.f: subroutine facemv (wt1,wt2,wt3,rnx,rny,rnz,smt,ifc)
mvmesh.f: subroutine faczqn (wt1,wt2,wt3,ifc,iel)
mvmesh.f: subroutine facsmt (smt,ifc)
mvmesh.f: subroutine cqnet (qni,ta,nel)
mvmesh.f: subroutine facemt (w1,w2,w3,rnx,rny,rnz,qni,dsa,smt,rhola,ifc)
mvmesh.f: subroutine elasolv (nel)
mvmesh.f: subroutine meshtol (ta,tolmsh,nel,imsolv)
mvmesh.f: subroutine updxyz (nel)
mvmesh.f: subroutine lagmshv (nel)
mvmesh.f: subroutine facec3 (a1,a2,a3,b1,b2,b3,ifc)
mvmesh.f: subroutine ptbgeom
mvmesh.f:C Subroutine to impose perturbation to geometry before solution
mvmesh.f: subroutine ibdgeom (nel)
mvmesh.f: subroutine inigeom (ux,uy,uz,x,y,z,iside,iel)
mvmesh.f: subroutine quickmv
mvmesh.f: subroutine quickmv2d
mvmesh.f: subroutine quickmv3d
mxm_std.f: subroutine mxmf2(A,N1,B,N2,C,N3)
mxm_std.f: subroutine mxf1(a,n1,b,n2,c,n3)
mxm_std.f: subroutine mxf2(a,n1,b,n2,c,n3)
mxm_std.f: subroutine mxf3(a,n1,b,n2,c,n3)
mxm_std.f: subroutine mxf4(a,n1,b,n2,c,n3)
mxm_std.f: subroutine mxf5(a,n1,b,n2,c,n3)
mxm_std.f: subroutine mxf6(a,n1,b,n2,c,n3)
mxm_std.f: subroutine mxf7(a,n1,b,n2,c,n3)
mxm_std.f: subroutine mxf8(a,n1,b,n2,c,n3)
mxm_std.f: subroutine mxf9(a,n1,b,n2,c,n3)
mxm_std.f: subroutine mxf10(a,n1,b,n2,c,n3)
mxm_std.f: subroutine mxf11(a,n1,b,n2,c,n3)
mxm_std.f: subroutine mxf12(a,n1,b,n2,c,n3)
mxm_std.f: subroutine mxf13(a,n1,b,n2,c,n3)
mxm_std.f: subroutine mxf14(a,n1,b,n2,c,n3)
mxm_std.f: subroutine mxf15(a,n1,b,n2,c,n3)
mxm_std.f: subroutine mxf16(a,n1,b,n2,c,n3)
mxm_std.f: subroutine mxf17(a,n1,b,n2,c,n3)
mxm_std.f: subroutine mxf18(a,n1,b,n2,c,n3)
mxm_std.f: subroutine mxf19(a,n1,b,n2,c,n3)
mxm_std.f: subroutine mxf20(a,n1,b,n2,c,n3)
mxm_std.f: subroutine mxf21(a,n1,b,n2,c,n3)
mxm_std.f: subroutine mxf22(a,n1,b,n2,c,n3)
mxm_std.f: subroutine mxf23(a,n1,b,n2,c,n3)
mxm_std.f: subroutine mxf24(a,n1,b,n2,c,n3)
mxm_std.f: subroutine mxm44_0(a, m, b, k, c, n)
mxm_std.f: subroutine mxm44_2(a, m, b, k, c, n)
mxm_wrapper.f: subroutine mxm(a,n1,b,n2,c,n3)
navier0.f: SUBROUTINE ESOLVER (RES,H1,H2,H2INV,INTYPE)
navier0.f: SUBROUTINE ESTRAT
navier0.f: SUBROUTINE EINIT
navier0.f: subroutine dmp_map(imap)
navier0.f: subroutine p_outvec_ir(ia,a,lda,name9)
navier1.f: subroutine plan1 (igeom)
navier1.f: subroutine crespuz (respr,g1,g2,g3,h1,h2,h2inv,intype)
navier1.f: subroutine cresvuz (resv1,resv2,resv3)
navier1.f: subroutine makeg (out1,out2,out3,h1,h2,intype)
navier1.f: subroutine ctolspl (tolspl,respr)
navier1.f: subroutine ortho (respr)
navier1.f: subroutine zaver1 (pm1)
navier1.f: subroutine cdabdtp (ap,wp,h1,h2,h2inv,intype)
navier1.f: subroutine opgrad (out1,out2,out3,inp)
navier1.f: subroutine cdtp (dtx,x,rm2,sm2,tm2,isd)
navier1.f: subroutine multd (dx,x,rm2,sm2,tm2,isd,iflg)
navier1.f: subroutine ophinv (out1,out2,out3,inp1,inp2,inp3,h1,h2,tolh,nmxi)
navier1.f: subroutine ophx (out1,out2,out3,inp1,inp2,inp3,h1,h2)
navier1.f: subroutine opbinv (out1,out2,out3,inp1,inp2,inp3,h2inv)
navier1.f: subroutine opbinv1(out1,out2,out3,inp1,inp2,inp3,SCALE)
navier1.f: subroutine uzprec (rpcg,rcg,h1m1,h2m1,intype,wp)
navier1.f: subroutine eprec (z2,r2)
navier1.f: subroutine convprn (iconv,rbnorm,rrpt,res,z,tol)
navier1.f: subroutine convpr (res,tol,iconv,rbnorm)
navier1.f: subroutine chktcg2 (tol,res,iconv)
navier1.f: subroutine dudxyz (du,u,rm1,sm1,tm1,jm1,imsh,isd)
navier1.f: subroutine convopo (conv,fi)
navier1.f: subroutine conv2 (dtfi,fi)
navier1.f: subroutine cmask (cmask1,cmask2)
navier1.f: subroutine makef
navier1.f: subroutine makeuf
navier1.f: subroutine nekuf (f1,f2,f3)
navier1.f: subroutine natconv
navier1.f: subroutine settbar (tbar)
navier1.f: subroutine advab
navier1.f: subroutine makebdf
navier1.f: subroutine makeabf
navier1.f: subroutine setab3 (ab0,ab1,ab2)
navier1.f: subroutine setabbd (ab,dtlag,nab,nbd)
navier1.f: subroutine setbd (bd,dtbd,nbd)
navier1.f: subroutine bdsys (a,b,dt,nbd,ndim)
navier1.f: subroutine advchar_old
navier1.f: subroutine ophyprkn(vel1,vel2,vel3,ilag)
navier1.f: subroutine ophypab (vel1,vel2,vel3,ilag)
navier1.f: subroutine tauinit (tau,ilag)
navier1.f: subroutine velinit (vel1,vel2,vel3,ilag)
navier1.f: subroutine velconv (vxn,vyn,vzn,tau)
navier1.f: subroutine frkconv (y,x,mask)
navier1.f: subroutine velchar (vel,vn,vlag,nbd,tau,dtbd)
navier1.f: subroutine lagvel
navier1.f: subroutine hypmsk3 (hv1msk,hv2msk,hv3msk)
navier1.f: subroutine setordbd
navier1.f: subroutine testmom (rmom,resv1,resv2,resv3,w1,w2,w3)
navier1.f: subroutine testdtp
navier1.f: subroutine tmultd
navier1.f: subroutine normsc (h1,semi,l2,linf,x,imesh)
navier1.f: subroutine normvc (h1,semi,l2,linf,x1,x2,x3)
navier1.f: subroutine genwp (wp,wm2,p)
navier1.f: subroutine convuz (ifstuz)
navier1.f: subroutine convsp (ifstsp)
navier1.f: subroutine antimsk (y,x,xmask,n)
navier1.f: subroutine opamask (vbdry1,vbdry2,vbdry3)
navier1.f: subroutine opmask (res1,res2,res3)
navier1.f: subroutine opadd2 (a1,a2,a3,b1,b2,b3)
navier1.f: subroutine opsub2 (a1,a2,a3,b1,b2,b3)
navier1.f: subroutine opsub3 (a1,a2,a3,b1,b2,b3,c1,c2,c3)
navier1.f: subroutine opcolv3(a1,a2,a3,b1,b2,b3,c)
navier1.f: subroutine opcolv (a1,a2,a3,c)
navier1.f: subroutine opcol2 (a1,a2,a3,b1,b2,b3)
navier1.f: subroutine opchsgn (a,b,c)
navier1.f: subroutine opcopy (a1,a2,a3,b1,b2,b3)
navier1.f: subroutine rotate_cyc(r1,r2,r3,idir)
navier1.f: subroutine opdssum (a,b,c)! NOTE: opdssum works on FLUID/MHD arrays only!
navier1.f: subroutine opdsop (a,b,c,op)! opdsop works on FLUID/MHD arrays only!
navier1.f: subroutine opicol2 (a1,a2,a3,b1,b2,b3)
navier1.f: subroutine oprzero (a,b,c)
navier1.f: subroutine oprone (a,b,c)
navier1.f: subroutine opcmult (a,b,c,const)
navier1.f: subroutine opcolv2c(a1,a2,a3,b1,b2,c)
navier1.f: subroutine opcolv2(a1,a2,a3,b1,b2)
navier1.f: subroutine opadd2col(a1,a2,a3,b1,b2,b3,c)
navier1.f: subroutine opcolv3c(a1,a2,a3,b1,b2,b3,c,d)
navier1.f: subroutine uzawa (rcg,h1,h2,h2inv,intype,iter)
navier1.f: subroutine spbslpf(abd,lda,n,m,b)
navier1.f: subroutine spbfapf(abd,lda,n,m,info)
navier1.f: subroutine mapw(md,nd,m1,n1,mflg)
navier1.f: subroutine mapwp(md,nd,m1,n1,mflg)
navier1.f: subroutine specmp(b,nb,a,na,ba,ab,w)
navier1.f: subroutine setmap(n1,nd)
navier1.f: subroutine set_PND(P,LkD,LkNt,N,D)
navier1.f: subroutine transpose(a,lda,b,ldb)
navier1.f: subroutine convop(conv,fi)
navier1.f: subroutine conv1d (dfi,fi)
navier1.f: subroutine conv1n(du,u)
navier1.f: subroutine conv1o(dfi,fi)
navier1.f: subroutine conv1 (dfi,fi)
navier1.f: subroutine conv1no(du,u)
navier1.f: subroutine conv1rk(du,dv,dw,u,v,w)
navier1.f: subroutine velconvv(vxn,vyn,vzn,tau)
navier1.f: subroutine frkconvv (du,dv,dw,u,v,w,mu)
navier1.f: subroutine conv1rk2(du,dv,dw,u,v,w,cu,cv,cw,beta,wk)
navier1.f: subroutine frkconvv2(du,dv,dw,u,v,w,cu,cv,cw,beta,mu,wk)
navier1.f: subroutine hypmsk3v(msk,mask)
navier1.f: subroutine ophyprk (vel1,vel2,vel3,ilag)
navier1.f: subroutine opdiv(outfld,inpx,inpy,inpz)
navier1.f: subroutine opgradt(outx,outy,outz,inpfld)
navier1.f: subroutine setproj(n1,nd)
navier1.f: subroutine set_PNDoi(Pt,P,LkNt,N,D)
navier1.f: subroutine wgradm1(ux,uy,uz,u,nel) ! weak form of grad
navier1.f: SUBROUTINE MAKEVIS
navier1.f: SUBROUTINE COMP_SIEJ (U1,U2,U3)
navier1.f: subroutine wlaplacian(out,a,diff,ifld)
navier2.f: subroutine aspect_ratios(ar)
navier2.f: subroutine eig2(AA,eign,eig1)
navier2.f: subroutine quadratic_h(x1,x2,a,b,c)
navier2.f: subroutine out_sem(iel)
navier2.f: subroutine gradm11(ux,uy,uz,u,e)
navier2.f: subroutine gradm11ts(u,ux,uy,uz,e)
navier2.f: subroutine makemsf(afx,afy,afz)
navier3.f: SUBROUTINE EPREC2(Z2,R2)
navier3.f: subroutine dd_solver(u,v)
navier3.f: subroutine rar2_out(x,name13)
navier3.f: subroutine rarr_out2(x,name13)
navier4.f: subroutine incompr
navier4.f: subroutine setrhs(p,h1,h2,h2inv)
navier4.f: subroutine gensoln(p,h1,h2,h2inv)
navier4.f: subroutine updtset(p,h1,h2,h2inv,IERR)
navier4.f: subroutine econj(kprev,h1,h2,h2inv,ierr)
navier4.f: subroutine chkptol
navier4.f: subroutine updrhse(p,h1,h2,h2inv,ierr)
navier4.f: subroutine echeck(kprev,h1,h2,h2inv,intetype)
navier4.f: subroutine savep(P,H1,H2,H2INV)
navier4.f: subroutine projh(r,h1,h2,bi,vml,vmk,approx,napprox,wl,ws,name4)
navier4.f: subroutine gensh(v1,h1,h2,vml,vmk,approx,napprox,wl,ws,name4)
navier4.f: subroutine hconj(approx,k,h1,h2,vml,vmk,ws,name4,ierr)
navier4.f: subroutine updrhsh(approx,napprox,h1,h2,vml,vmk,ws,name4)
navier4.f: subroutine hmhzpf(name,u,r,h1,h2,mask,mult,imesh,tli,maxit,isd,bi)
navier4.f: subroutine hsolve(name,u,r,h1,h2,vmk,vml,imsh,tol,maxit,isd
navier5.f: subroutine q_filter(wght)
navier5.f: subroutine filterq(v,f,nx,nz,w1,w2,ft,if3d,dmax)
navier5.f: subroutine outmatx(a,m,n,io,name)
navier5.f: subroutine drag_calc(scale)
navier5.f: subroutine mappr(pm1,pm2,pa,pb)
navier5.f: subroutine out_csrmats(acsr,ia,ja,n,name9)
navier5.f: subroutine local_grad3(ur,us,ut,u,N,e,D,Dt)
navier5.f: subroutine local_grad2(ur,us,u,N,e,D,Dt)
navier5.f: subroutine gradm1(ux,uy,uz,u)
navier5.f: subroutine outpost(v1,v2,v3,vp,vt,name3)
navier5.f: subroutine outpost2(v1,v2,v3,vp,vt,nfldt,name3)
navier5.f: subroutine comp_vort3(vort,work1,work2,u,v,w)
navier5.f: subroutine surface_int(sint,sarea,a,ie,iface1)
navier5.f: subroutine surface_flux(dq,qx,qy,qz,ie,iface,w)
navier5.f: subroutine gaujordf(a,m,n,indr,indc,ipiv,ierr,rmult)
navier5.f: subroutine legendre_poly(L,x,N)
navier5.f: subroutine build_new_filter(intv,zpts,nx,kut,wght,nid)
navier5.f: subroutine avg_all
navier5.f: subroutine avg1(avg,f,alpha,beta,n,name,ifverbose)
navier5.f: subroutine avg2(avg,f,alpha,beta,n,name,ifverbose)
navier5.f: subroutine avg3(avg,f,g,alpha,beta,n,name,ifverbose)
navier5.f: subroutine build_legend_transform(Lj,Ljt,zpts,nx)
navier5.f: subroutine local_err_est(err,u,nx,Lj,Ljt,uh,w,if3d)
navier5.f: subroutine transpose1(a,n)
navier5.f: subroutine get_exyz(ex,ey,ez,eg,nelx,nely,nelz)
navier5.f: subroutine dump_header2d(excode,nx,ny,nlx,nly)
navier5.f: subroutine outfld2d_p(u,v,w,nx,ny,nlx,nly,name,ifld,jid,npido)
navier5.f: subroutine outfld2d(u,v,w,nx,ny,nlx,nly,name,ifld)
navier5.f: subroutine planar_average_z(ua,u,w1,w2)
navier5.f: subroutine drgtrq(dgtq,xm0,ym0,zm0,sij,pm1,visc,f,e)
navier5.f: subroutine torque_calc(scale,x0,ifdout,iftout)
navier5.f: subroutine comp_sij(sij,nij,u,v,w,ur,us,ut,vr,vs,vt,wr,ws,wt)
navier5.f: subroutine y_slice (ua,u,w1,w2)
navier5.f: subroutine z_slice (ua,u,w1,w2)
navier5.f: subroutine y_average(ua,u,w1,w2)
navier5.f: subroutine z_average(ua,u,w1,w2)
navier5.f: subroutine y_avg_buff(ux,uy,uz,c2,name,icount)
navier5.f: subroutine z_avg_buff(ux,uy,uz,c2,name,icount)
navier5.f: subroutine y_ins_buff(ux,uy,uz,c2,name,icount)
navier5.f: subroutine z_ins_buff(ux,uy,uz,c2,name,icount)
navier5.f: subroutine buff_2d_out(u,v,w,nx,ny,nex,ney,c2,name,ifld)
navier5.f: subroutine y2d(u,v,w,p,c1,icount)
navier5.f: subroutine z2d(u,v,w,p,c1,icount)
navier5.f: subroutine anal_2d
navier5.f: subroutine chkit(u,name4,n)
navier5.f: subroutine outmesh
navier5.f: subroutine out_el(xt,e)
navier5.f: subroutine get_el(xt,x,y,z)
navier5.f: subroutine shear_calc_max(strsmx,scale,x0,ifdout,iftout)
navier5.f: subroutine get_strsmax(strsmax,xm0,ym0,zm0,sij,pm1,visc,f,e)
navier5.f: subroutine fix_geom ! fix up geometry irregularities
navier5.f: subroutine gh_face_extend(x,zg,n,gh_type,e,v)
navier5.f: subroutine gh_face_extend_2d(x,zg,n,gh_type,e,v)
navier5.f: subroutine gh_face_extend_3d(x,zg,n,gh_type,e,v)
navier5.f: subroutine rand_fld_h1(x)
navier5.f: subroutine rescale_x (x,x0,x1)
navier6.f: subroutine set_overlap
navier6.f: subroutine overflow_ck(n_req,n_avail,signal)
navier6.f: subroutine iunswap(b,ind,n,temp)
navier6.f: subroutine set_fem_data_l2(nep,nd,no,x,y,z,p)
navier6.f: subroutine map_face12(x2,x1,w1,w2)
navier6.f: subroutine map_one_face12(x2,x1,iface,i12,i12t,w1,w2)
navier6.f: subroutine dface_add1sa(x)
navier6.f: subroutine faces(a,s,ie,iface,nx,ny,nz)
navier7.f: subroutine out_acsr(acsr,ia,ja,n)
navier7.f: subroutine compress_acsr(acsr,ia,ja,n)
navier7.f: subroutine outbox(xmax,xmin,ymax,ymin,io)
navier7.f: subroutine imout(x,m,n,name)
navier7.f: subroutine out_abd(abd,lda,n,m)
navier7.f: subroutine rarr_out(x,name13)
navier7.f: subroutine iarr_out(x,name)
navier7.f: subroutine iar2_out(x,name)
navier7.f: subroutine scsr_permute(bcsr,ib,jb,acsr,ia,ja,n
navier7.f: write(6,*) 'HMT HACK in subroutine scsr_permute() ... pls fix!'
navier7.f: subroutine scsr_to_spb(abd,lda,acsr,ia,ja,n)
navier7.f: subroutine scsr_to_spbm(abd,lda,acsr,ia,ja,n)
navier7.f: subroutine out_spbmat(abd,n,lda,name)
navier7.f: subroutine swap(b,ind,n,temp)
navier7.f: subroutine ipermute(a,icperm,n,b)
navier7.f: subroutine out_csrmat(acsr,ia,ja,n,name9)
navier8.f: subroutine set_vert(glo_num,ngv,nx,nel,vertex,ifcenter)
navier8.f: subroutine crs_solve_l2(uf,vf)
navier8.f:c subroutine test_h1_crs
navier8.f: subroutine set_up_h1_crs
navier8.f: subroutine set_jl_crs_mask(n, mask, se_to_gcrs)
navier8.f: subroutine set_mat_ij(ia,ja,n,ne)
navier8.f: subroutine irank_vec(ind,nn,a,m,n,key,nkey,aa)
navier8.f: subroutine ituple_sort(a,lda,n,key,nkey,ind,aa)
navier8.f: subroutine tuple_sort(a,lda,n,key,nkey,ind,aa)
navier8.f: subroutine get_local_crs(a,lda,nxc,h1,h2,w,ldw)
navier8.f: subroutine a_crs_enriched(a,h1,h2,x1,y1,z1,nxc,if3d,ie)
navier8.f: subroutine a_crs_3d(a,h1,h2,xc,yc,zc,ie)
navier8.f: subroutine bindec(bin_in)
navier8.f: subroutine get_local_A_tet(a,x,y,z,kt,ie)
navier8.f: subroutine a_crs_2d(a,h1,h2,x,y,ie)
navier8.f: subroutine map_m_to_n(a,na,b,nb,if3d,w,ldw)
navier8.f: subroutine specmpn(b,nb,a,na,ba,ab,if3d,w,ldw)
navier8.f: subroutine irank(A,IND,N)
navier8.f: subroutine iranku(r,input,n,w,ind)
navier8.f: subroutine ifacev_redef(a,ie,iface,val,nx,ny,nz)
navier8.f: subroutine map_c_to_f_l2_bilin(uf,uc,w)
navier8.f: subroutine map_f_to_c_l2_bilin(uc,uf,w)
navier8.f: subroutine maph1_to_l2(a,na,b,nb,if3d,w,ldw)
navier8.f: subroutine maph1_to_l2t(b,nb,a,na,if3d,w,ldw)
navier8.f: subroutine irank_vec_tally(ind,nn,a,m,n,key,nkey,key2,aa)
navier8.f: subroutine out_se1(se2crs,nx,name)
navier8.f: subroutine out_se0(se2crs,nx,nel,name)
navier8.f: subroutine crs_solve_h1(uf,vf)
navier8.f: subroutine set_h1_basis_bilin
navier8.f: subroutine map_c_to_f_h1_bilin(uf,uc)
navier8.f: subroutine map_f_to_c_h1_bilin(uc,uf)
navier8.f: subroutine get_local_crs_galerkin(a,ncl,nxc,h1,h2,w1,w2)
navier8.f: subroutine gen_crs_basis(b,j) ! bi- tri-linear
navier8.f: subroutine gen_crs_basis2(b,j) ! bi- tri-quadratic
navier8.f: subroutine get_vertex
navier8.f: subroutine assign_gllnid(gllnid,iunsort,nelgt,nelgv,np)
navier8.f: subroutine get_vert
navier8.f: subroutine get_vert_map(vertex, nlv, nel, suffix)
navier8.f: subroutine irank_vecn(ind,nn,a,m,n,key,nkey,aa)
navier8.f: subroutine gbtuple_rank(tuple,m,n,nmax,cr_h,nid,np,ind)
navier8.f: subroutine setvert3d(glo_num,ngv,nx,nel,vertex,ifcenter)
navier8.f: subroutine setvert2d(glo_num,ngv,nx,nel,vertex,ifcenter)
papi.f: subroutine nek_flops(flops,mflops)
papi.f: subroutine getflops_papi(flops,mflops)
pertsupport.f: subroutine flushBuffer(k)
pertsupport.f: subroutine opscale(v1,v2,v3,temp,alpha)
pertsupport.f: subroutine opscaleV(v1,v2,v3,alpha)
pertsupport.f: subroutine computelyap
pertsupport.f: subroutine computelyap1(vxq,vyq,vzq,tq,jpp)
pertsupport.f: subroutine rescalepert(pertnorm,pertinvnorm,jpp)
pertsupport.f: subroutine writehist(v1,v2,v3,temp,jpp)
pertsupport.f: subroutine initialize
pertsupport.f: subroutine initialize1(jpp)
pertsupport.f: subroutine get_useric
pertsupport.f: subroutine out_pert ! dump perturbation .fld files
pertsupport.f: subroutine pert_add2s2(i,j,scale) ! xi = xi + scale * xj
pertsupport.f: subroutine pert_ortho_norm ! orthogonalize and rescale pert. arrays
pertsupport.f: subroutine pert_ortho_norm1 (k) ! orthogonalize k against 1...k-1
perturb.f: subroutine fluidp (igeom)
perturb.f: subroutine perturbv (igeom)
perturb.f: subroutine lagfieldp
perturb.f: subroutine makefp
perturb.f: subroutine makeufp
perturb.f: subroutine advabp
perturb.f: subroutine makextp
perturb.f: subroutine makebdfp
perturb.f: subroutine cresvipp(resv1,resv2,resv3,h1,h2)
perturb.f: subroutine heatp (igeom)
perturb.f: subroutine cdscalp (igeom)
perturb.f: subroutine makeqp
perturb.f: subroutine makeuqp
perturb.f: subroutine convabp
perturb.f: subroutine makeabqp
perturb.f: subroutine makebdqp
perturb.f: subroutine lagscalp
perturb.f: subroutine incomprp (ux,uy,uz,up)
perturb.f: subroutine extrapprp (prextr)
perturb.f: subroutine lagpresp
perturb.f: subroutine lyap_scale ! Rescale / orthogonalize perturbation fields
perturb.f: subroutine out_pert ! dump perturbation .fld files
perturb.f: subroutine pert_add2s2(i,j,scale) ! xi = xi + scale * xj
perturb.f: subroutine pert_ortho_norm ! orthogonalize and rescale pert. arrays
perturb.f: subroutine pert_ortho_norm1 (k) ! orthogonalize k against 1...k-1
perturb.f: subroutine opscale(v1,v2,v3,temp,alpha)
perturb.f: subroutine opscaleV(v1,v2,v3,alpha)
perturb.f: subroutine computelyap
perturb.f: subroutine computelyap1(vxq,vyq,vzq,tq,jpp)
perturb.f: subroutine rescalepert(pertnorm,pertinvnorm,jpp)
plan4.f: subroutine plan4
plan4.f:c by an external subroutine e.g qthermal
plan4.f: subroutine crespsp (respr)
plan4.f: subroutine cresvsp (resv1,resv2,resv3,h1,h2)
plan4.f: subroutine op_curl(w1,w2,w3,u1,u2,u3,ifavg,work1,work2)
plan4.f: subroutine opadd2cm (a1,a2,a3,b1,b2,b3,c)
plan4.f: subroutine split_vis
plan4.f: subroutine redo_split_vis
plan4.f: subroutine v_extrap(vext)
planx.f: SUBROUTINE PLAN3 (IGEOM)
planx.f: SUBROUTINE LAGPRES
planx.f: SUBROUTINE CRESVIF (RESV1,RESV2,RESV3,H1,H2)
planx.f: SUBROUTINE EXTRAPP (PREXTR)
planx.f: subroutine ophinvpr(ot1,ot2,ot3,in1,in2,in3,h1,h2,tolh,nmxi)
planx.f: subroutine hmzpf2(nm,u,rhs,h1,h2,mask,mult,imsh,tol,mxit,isd)
planx.f: subroutine projh2(v1,h1,h2,vml,vmask,isd)
planx.f: subroutine gensh2(v1,h1,h2,vml,vmask,isd)
planx.f: subroutine updtseth2(v1,h1,h2,vml,vmask,isd)
planx.f: subroutine hconj2(kprev,h1,h2,vml,vmask,isd)
planx.f: subroutine updrhsh2(h1,h2,vml,vmask,isd)
postpro.f: subroutine load_fld(string)
postpro.f: subroutine lambda2(l2)
postpro.f: subroutine find_lam3(lam,aa,w,ndim,ierr)
postpro.f: subroutine quadratic(x1,x2,a,b,c,ierr)
postpro.f: subroutine cubic(xo,ai1,ai2,ai3,ierr)
postpro.f: subroutine comp_gije(gije,u,v,w,e)
postpro.f: subroutine filter_s1(scalar,tf,nx,nel) ! filter scalar field
postpro.f: subroutine filter_s0(scalar,wght,ncut,name5) ! filter scalar field
postpro.f: subroutine intpts_setup(tolin)
postpro.f: subroutine intpts(fieldin,nfld,iTl,mi,rTl,mr,n,iffindin,ih)
postpro.f: subroutine intpts_done()
postpro.f: subroutine tens3d1(v,u,f,ft,nv,nu) ! v = F x F x F x u
postpro.f: subroutine build_1d_filt(fh,fht,trnsfr,nx,nid)
postpro.f: subroutine mag_tensor_e(mag,aije)
postpro.f: subroutine comp_sije(gije)
postpro.f: subroutine map2reg(ur,n,u,nel)
postpro.f: subroutine map2reg_2di_e(uf,n,uc,m) ! Fine, uniform pt
postpro.f: subroutine map2reg_3di_e(uf,n,uc,m) ! Fine, uniform pt
postpro.f: subroutine gen_int_gz(j,jt,g,n,z,m)
postpro.f: subroutine zuni(z,np)
postpro.f: subroutine gen_rea(imid) ! Generate and output essential parts of .rea
postpro.f: subroutine gen_rea_xyz
postpro.f: subroutine gen_rea_curve(imid)
postpro.f: subroutine gen_rea_bc (ifld)
postpro.f: subroutine gen_rea_midside_e(e)
postpro.f: subroutine hpts
prepost.f: subroutine prepost(ifdoin,prefin)
prepost.f: subroutine prepost_map(isave) ! isave=0-->fwd, isave=1-->bkwd
prepost.f: subroutine outfld(prefix)
prepost.f: subroutine outhis(ifhis) ! output time history info
prepost.f: subroutine intglq
prepost.f: subroutine bdforce
prepost.f: subroutine bdheat
prepost.f: subroutine setsmu (smult)
prepost.f: subroutine file2(nopen,PREFIX)
prepost.f: subroutine rzero4(a,n)
prepost.f: subroutine copyX4(a,b,n)
prepost.f: subroutine copy4r(a,b,n)
prepost.f: subroutine dump_header(excodein,p66)
prepost.f: subroutine fill_tmp(tdump,id,ie)
prepost.f: subroutine get_id(id)
prepost.f: subroutine close_fld(p66)
prepost.f: subroutine out_tmp(id,p66)
prepost.f: subroutine mfo_outfld(prefix) ! muti-file output
prepost.f: subroutine io_init ! determine which nodes will output
prepost.f: subroutine mfo_open_files(prefix) ! open files
prepost.f: subroutine restart_nfld( nfld, prefix )
prepost.f: subroutine restart_save(iosave,save_size,nfldi)
prepost.f: subroutine mfo_mdatav(u,v,w,nel)
prepost.f: subroutine mfo_mdatas(u,nel)
prepost.f: subroutine mfo_outs(u,nel,mx,my,mz) ! output a scalar field
prepost.f: subroutine mfo_outv(u,v,w,nel,mx,my,mz) ! output a vector field
prepost.f: subroutine mfo_write_hdr ! write hdr, byte key, els.
qthermal.f: subroutine qthermal
setprop.f: subroutine setprop
speclib.f: SUBROUTINE ZWGL (Z,W,NP)
speclib.f: SUBROUTINE ZWGLL (Z,W,NP)
speclib.f: SUBROUTINE ZWGJ (Z,W,NP,ALPHA,BETA)
speclib.f: SUBROUTINE ZWGJD (Z,W,NP,ALPHA,BETA)
speclib.f: SUBROUTINE ZWGLJ (Z,W,NP,ALPHA,BETA)
speclib.f: SUBROUTINE ZWGLJD (Z,W,NP,ALPHA,BETA)
speclib.f: SUBROUTINE JACG (XJAC,NP,ALPHA,BETA)
speclib.f: SUBROUTINE JACOBF (POLY,PDER,POLYM1,PDERM1,POLYM2,PDERM2,
speclib.f: SUBROUTINE DGJ (D,DT,Z,NZ,NZD,ALPHA,BETA)
speclib.f: SUBROUTINE DGJD (D,DT,Z,NZ,NZD,ALPHA,BETA)
speclib.f: SUBROUTINE DGLJ (D,DT,Z,NZ,NZD,ALPHA,BETA)
speclib.f: SUBROUTINE DGLJD (D,DT,Z,NZ,NZD,ALPHA,BETA)
speclib.f: SUBROUTINE DGLL (D,DT,Z,NZ,NZD)
speclib.f: WRITE (6,*) 'Subroutine DGLL'
speclib.f: SUBROUTINE DGLLGL (D,DT,ZM1,ZM2,IM12,NZM1,NZM2,ND1,ND2)
speclib.f:C (see subroutine IGLLGL).
speclib.f: SUBROUTINE DGLJGJ (D,DT,ZGL,ZG,IGLG,NPGL,NPG,ND1,ND2,ALPHA,BETA)
speclib.f:C (see subroutine IGLJGJ).
speclib.f: SUBROUTINE DGLJGJD (D,DT,ZGL,ZG,IGLG,NPGL,NPG,ND1,ND2,ALPHA,BETA)
speclib.f:C (see subroutine IGLJGJ).
speclib.f: SUBROUTINE IGLM (I12,IT12,Z1,Z2,NZ1,NZ2,ND1,ND2)
speclib.f: SUBROUTINE IGLLM (I12,IT12,Z1,Z2,NZ1,NZ2,ND1,ND2)
speclib.f: SUBROUTINE IGJM (I12,IT12,Z1,Z2,NZ1,NZ2,ND1,ND2,ALPHA,BETA)
speclib.f: SUBROUTINE IGLJM (I12,IT12,Z1,Z2,NZ1,NZ2,ND1,ND2,ALPHA,BETA)
ssolv.f: SUBROUTINE SSTEST (ISSS)
ssolv.f: SUBROUTINE SSINIT (KMAX)
ssolv.f: SUBROUTINE CHKEXT (IFACCX,Z,S)
ssolv.f: SUBROUTINE FILLLAG
ssolv.f: SUBROUTINE GONSTEP (N,ITEST)
ssolv.f: SUBROUTINE GO1STEP (X,Y,NVEC)
ssolv.f: SUBROUTINE GOSTEP
ssolv.f: SUBROUTINE MODPROP
ssolv.f: SUBROUTINE MKVEC (X)
ssolv.f: SUBROUTINE MKARR (X)
ssolv.f: SUBROUTINE SSPARAM (KMAX,L)
ssolv.f: SUBROUTINE CHKSSVT
ssolv.f: SUBROUTINE CHKSSV
ssolv.f: SUBROUTINE CHKSST
ssolv.f: SUBROUTINE SSNORMD (DV1,DV2,DV3)
ssolv.f: SUBROUTINE SSNORMP (DV1,DV2,DV3)
ssolv.f: SUBROUTINE SETTOLV
ssolv.f:C See subroutine CHKSSV
ssolv.f: SUBROUTINE SETTOLT
ssolv.f: SUBROUTINE CHKTOLP (TOLMIN)
ssolv.f: SUBROUTINE SETCHAR
ssolv.f: SUBROUTINE PROJECT
subs1.f: SUBROUTINE SETDT
subs1.f: SUBROUTINE CVGNLPS (IFCONV)
subs1.f: SUBROUTINE UNORM
subs1.f: SUBROUTINE CHKTMG (TOL,RES,W1,W2,MULT,MASK,IMESH)
subs1.f: SUBROUTINE SETDTC
subs1.f: SUBROUTINE CUMAX (V1,V2,V3,UMAX)
subs1.f: SUBROUTINE SETDTFS (DTFS)
subs1.f: SUBROUTINE CDXMIN2 (DTST,RHOSIG,IEL,IFC,IFAXIS)
subs1.f: SUBROUTINE CDXMIN3 (DTST,RHOSIG,IEL,IFC)
subs1.f: SUBROUTINE FCAVER(XAVER,A,IEL,IFACE1)
subs1.f: SUBROUTINE FACCL2(A,B,IFACE1)
subs1.f: SUBROUTINE FACCL3(A,B,C,IFACE1)
subs1.f: SUBROUTINE FADDCL3(A,B,C,IFACE1)
subs1.f: subroutine sethlm (h1,h2,intloc)
subs1.f: SUBROUTINE VPROPS
subs1.f: SUBROUTINE NEKUVP (IEL)
subs1.f: SUBROUTINE DIAGNOS
subs1.f: SUBROUTINE SETSOLV
subs1.f: SUBROUTINE MGGO
subs1.f: SUBROUTINE MGINIT
subs1.f: SUBROUTINE HMHZSF (NAME,U1,U2,U3,R1,R2,R3,H1,H2,
subs1.f: SUBROUTINE CHKTCGS (R1,R2,R3,RMASK1,RMASK2,RMASK3,RMULT,BINV,
subs1.f: SUBROUTINE CGGOSF (U1,U2,U3,R1,R2,R3,H1,H2,RMULT,BINV,
subs1.f: SUBROUTINE AXHMSF (AU1,AU2,AU3,U1,U2,U3,H1,H2,MATMOD)
subs1.f: SUBROUTINE STNRATE (U1,U2,U3,NEL,MATMOD)
subs1.f: SUBROUTINE UXYZ (U,EX,EY,EZ,NEL)
subs1.f: SUBROUTINE URST (U,UR,US,UT,NEL)
subs1.f: SUBROUTINE DDRST (U,UR,US,UT)
subs1.f: SUBROUTINE AXIEZZ (U2,EYY,EZZ,NEL)
subs1.f: subroutine flush_io
subs1.f: subroutine fcsum2(xsum,asum,x,e,f)
subs2.f: SUBROUTINE STRESS (H1,H2,NEL,MATMOD,IFAXIS)
subs2.f: SUBROUTINE AIJUJ (AU1,AU2,AU3,NEL,IFAXIS)
subs2.f: SUBROUTINE TTXYZ (FF,TX,TY,TZ,NEL)
subs2.f: SUBROUTINE TTRST (FF,FR,FS,FT,TA)
subs2.f: SUBROUTINE AXITZZ (VFY,TZZ,NEL)
subs2.f: SUBROUTINE SETAXDY (IFAXDY)
subs2.f: SUBROUTINE SETAXW1 (IFAXWG)
subs2.f: SUBROUTINE SETAXW2 (IFAXWG)
subs2.f: SUBROUTINE STNRINV
subs2.f: SUBROUTINE OPDOT (DP,A1,A2,A3,B1,B2,B3,N)
subs2.f: SUBROUTINE OPADDS (A1,A2,A3,B1,B2,B3,CONST,N,ISC)
subs2.f: SUBROUTINE FACEXS (A,B,IFACE1,IOP)
subs2.f: SUBROUTINE FACEXV (A1,A2,A3,B1,B2,B3,IFACE1,IOP)
subs2.f: SUBROUTINE FACSUB2 (A1,A2,A3,B1,B2,B3,IFACE1)
subs2.f: SUBROUTINE GAMMASF (H1,H2)
subs2.f: SUBROUTINE CMULT2 (A,B,CONST,N)
subs2.f: SUBROUTINE ADD3S (A,B,C,CONST,N)
subs2.f: SUBROUTINE EMERXIT
subs2.f: SUBROUTINE FACCVS (A1,A2,A3,B,IFACE1)
subs2.f: SUBROUTINE STX1SF
subs2.f: SUBROUTINE SOLVEL
subs2.f: SUBROUTINE VSOLN (UX,UY,UZ,X,Y,Z,PI)
subs2.f: SUBROUTINE SOLPRES
subs2.f: SUBROUTINE PRSOLN (P,X,Y,Z,PI)
subs2.f: SUBROUTINE STORE
subs2.f: SUBROUTINE PRINTEL (TA,A,IEL)
subs2.f: SUBROUTINE PRINTV (TA,A,NEL)
subs2.f: SUBROUTINE OUTF1 (X,TXT,IEL,IFC)
subs2.f: SUBROUTINE OUTM1 (X,TXT,NP,IEL,IP)
subs2.f: SUBROUTINE OUTM2 (X,TXT,NP,IEL,IP)
subs2.f: SUBROUTINE STSMASK (C1MASK,C2MASK,C3MASK)
subs2.f: SUBROUTINE UPDMSYS (IFLD)
subs2.f: SUBROUTINE SETHMSK (HVMASK,HFMASK,IFLD,NEL)
subs2.f: SUBROUTINE SKIPCNR (NEL)
subs2.f: SUBROUTINE SETMASK (C1MASK,C2MASK,C3MASK,HVMASK,NEL)
subs2.f: SUBROUTINE SETMLOG (HVMASK,HFMASK,IFLD,NEL)
subs2.f: SUBROUTINE SETCSYS (HVMASK,HFMASK,NEL)
subs2.f: SUBROUTINE COMAVN2 (HVMASK,HFMASK,NEL)
subs2.f: SUBROUTINE COMAVN3 (HVMASK,HFMASK,NEL)
subs2.f: SUBROUTINE FIXWMSK (W2MASK,W3MASK,HVMASK,HFMASK,NEL)
subs2.f: SUBROUTINE FXWMS2 (W2MASK,HVMASK,HFMASK,NEL)
subs2.f: SUBROUTINE FXWMS3 (W2MASK,W3MASK,HVMASK,HFMASK,NEL)
subs2.f: SUBROUTINE SETCDAT
subs2.f: SUBROUTINE EDGINDF (LF1,LF2,LFSKIP,ISD,IFCN)
subs2.f: SUBROUTINE EDGINDV (LV1,LV2,LVSKIP,ISD)
subs2.f: SUBROUTINE SETCDOF
subs2.f: SUBROUTINE AMASK (VB1,VB2,VB3,V1,V2,V3,NEL)
subs2.f: SUBROUTINE RMASK (R1,R2,R3,NEL)
subs2.f: SUBROUTINE QMASK (R1,R2,R3,R1MASK,R2MASK,R3MASK,NEL)
subs2.f: SUBROUTINE FCMSK2 (R1,R2,S1,S2,R1MASK,R2MASK,NEL)
subs2.f: SUBROUTINE FCMSK3 (R1,R2,R3,S1,S2,S3,R1MASK,R2MASK,R3MASK,NEL)
subs2.f: SUBROUTINE EGMASK (R1,R2,R3,S1,S2,S3,R1MASK,R2MASK,R3MASK,NEL)
subs2.f: SUBROUTINE CRMSK2 (R1,R2,S1,S2,R1MASK,R2MASK,NEL)
subs2.f: SUBROUTINE CRMSK3 (R1,R2,R3,S1,S2,S3,R1MASK,R2MASK,R3MASK,NEL)
subs2.f: subroutine getSnormal(sn,ix,iy,iz,iside,e)
turb.f: SUBROUTINE SETTURB
turb.f: SUBROUTINE PRETMIC
turb.f: SUBROUTINE POSTMIC
turb.f: SUBROUTINE CBCTURB
turb.f: SUBROUTINE WHATFLD (IFTURB)
turb.f: SUBROUTINE TURBFLD (IFKFLD,IFEFLD)
turb.f: SUBROUTINE TVISCOS
turb.f: SUBROUTINE TVISCKE
turb.f: SUBROUTINE TVISCA
turb.f: SUBROUTINE TPROPK
turb.f: SUBROUTINE TPROPE
turb.f: SUBROUTINE MAKETQ
turb.f: SUBROUTINE SETQK
turb.f: SUBROUTINE SETQE
turb.f: SUBROUTINE TURBQK
turb.f: SUBROUTINE TURBQE
turb.f: SUBROUTINE TURBWBC (TMP,TMA,SMU)
turb.f: SUBROUTINE FACEWSK (S,IEL,IFC)
turb.f: SUBROUTINE FACEWSE (S,IEL,IFC)
turb.f: SUBROUTINE SETTMC
turb.f: SUBROUTINE COMPHI (PHI)
turb.f: SUBROUTINE INIPHI (PHI)
turb.f: SUBROUTINE TWALLUZ (IGEOM)
turb.f: SUBROUTINE TWALLSH
turb.f: SUBROUTINE FACEWS (TRX,TRY,TRZ,IEL,IFC)
turb.f: SUBROUTINE COMWUZ (XWLL,YWLL,ZWLL,V1,V2,V3,VISKIN,VISMIN,IEL,IFC)
turb.f: SUBROUTINE NORIND (JS3,JF3,JSKIP3,IWX,IWY,IFC,ISCH)
turb.f: SUBROUTINE CWREF (XWLL,YWLL,ZWLL,UTW,ZNW,VTAN1,VTAN2,VTAN3,
turb.f: SUBROUTINE COMTDIR (VTAN1,VTAN2,VTAN3,JWX,JWY,IWZ,IEL,IFC)
turb.f: SUBROUTINE SUBGRID (UTW,ZNW,UW,ZW,ZL,ZU,UL,UU,AKVIS,UST1,IEL,IFC,
turb.f: SUBROUTINE COMUFR (UST,U,Z,AKVIS,UST1,IEL,IFC,JWX,JWY)
turb.f: SUBROUTINE COMLSQ
turb.f: SUBROUTINE LSCALE
turb.f: SUBROUTINE TLMASK (SMASK)
turb.f: SUBROUTINE BCDIRTL (TLS,SMS,TMP)
turb.f: SUBROUTINE FACEWL (S,IEL,IFC)
turb.f: SUBROUTINE GETVAR (V,VP,RP)
turb.f: SUBROUTINE INVCHK2 (A,B,N)
turb.f: SUBROUTINE FACIND2 (JS1,JF1,JSKIP1,JS2,JF2,JSKIP2,IFC)
bdry.f:C Assign fortran function boundary conditions to
calcz.f: function pythag(a,b)
comm_mpi.f: integer function numnodes()
comm_mpi.f: integer function mynode()
comm_mpi.f: real*8 function dnekclock()
comm_mpi.f: real*8 function dnekclock_sync()
comm_mpi.f: function isend(msgtag,x,len,jnid,jpid)
comm_mpi.f: function irecv(msgtag,x,len)
comm_mpi.f: function igl_running_sum(in)
conduct.f:c Fill up user defined forcing function and collocate will the
conduct.f: time = time-dt ! Set time to t^n-1 for user function
conduct.f:c Set user specified volumetric forcing function (e.g. heat source).
conduct.f:C Eulerian scheme, add convection term to forcing function
conduct.f:c Eulerian scheme, add diffusion term to forcing function
connect1.f: FUNCTION VOLUM0(P1,P2,P3,P0)
connect1.f: FUNCTION CRSS2D(XY1,XY2,XY0)
connect2.f:C check for fortran function as denoted by lower case bc's:
connect2.f:C check for fortran function as denoted by lower case bc's:
connect2.f:C check for fortran function as denoted by lower case bc's:
cvode_driver.f:c f denotes the RHS function and is evaluated in fcvfun().
cvode_driver.f:c Compute RHS function f (allocated within cvode)
dssum.f:c o note: a binary function pointer flavor exists.
genbox.f: function ilsum(x,n)
genxyz.f:C Load parameters for surface function FNC
genxyz.f:C Given a function FNC and an initial guess (X1,X2), the routine
genxyz.f: FUNCTION ZBRENT(X1,X2,TOL)
genxyz.f:C of a function FNC known to lie between X1 and X2. The root,
genxyz.f: FUNCTION FNC(ETA)
genxyz.f: LOGICAL FUNCTION IFVCHK(VEC,I1,I2,I3)
genxyz.f: REAL FUNCTION DOT(V1,V2,N)
genxyz.f: function ressrf(x,c,cc)
hmholtz.f: function vlsc32(r,b,m,n)
ic.f:C (1) - User specified fortran function (default is zero i.c.)
ic.f:C Fortran function initial conditions for temp/pass. scalars.
ic.f:C Fortran function initial conditions for velocity.
ic.f:C Fortran function initial conditions for turbulence k-e model
ic.f:C Default is user specified fortran function (=0 if not specified)
ic.f: function i1_from_char(s1)
ic.f: integer function indx2(s1,l1,s2,l2)
ic.f: INTEGER FUNCTION INDX1(S1,S2,L2)
ic.f: INTEGER FUNCTION INDX_CUT(S1,S2,L2)
ic.f:C User specified fortran function (=0 if not specified)
ic.f: LOGICAL FUNCTION IFGTRL(VALUE,LINE)
ic.f:C This complicated function is necessary thanks to the Ardent,
ic.f: LOGICAL FUNCTION IFGTIL(IVALUE,LINE)
ic.f:C This complicated function is necessary thanks to the Ardent,
ic.f: logical function if_byte_swap_test(bytetest)
induct.f:c Compute and add: (1) user specified forcing function (FX,FY,FZ)
induct.f:C Eulerian scheme, add convection term to forcing function
induct.f:C Eulerian scheme, add convection term to forcing function
makeq.f:C Generate forcing function for the solution of a passive scalar.
math.f: real function vlmin(vec,n)
math.f: integer function ivlmin(vec,n)
math.f: integer function ivlmax(vec,n)
math.f: real function vlmax(vec,n)
math.f: real function vlamax(vec,n)
math.f: real function vlsum(vec,n)
math.f:C Map and add to S a tensor product form of the three functions H1,H2,H3.
math.f: function ltrunc(string,l)
math.f: function mod1(i,n)
math.f: $ 'WARNING: Attempt to take MOD(I,0) in function mod1.'
math.f: integer function log2(k)
math.f: real function vlsc2(x,y,n)
math.f: real function vlsc21(x,y,n)
math.f: function glsc3(a,b,mult,n)
math.f: function glsc2(x,y,n)
math.f: function glsc23(x,y,z,n)
math.f: real function gl2norm(a,n)
math.f: function glsum (x,n)
math.f: real function glamax(a,n)
math.f: real function glamin(a,n)
math.f: function iglmin(a,n)
math.f: function iglmax(a,n)
math.f: function iglsum(a,n)
math.f: integer*8 function i8glsum(a,n)
math.f: function glmax(a,n)
math.f: function glmin(a,n)
math.f: function fmdian(a,n,ifok)
math.f: function ivlsum(a,n)
math.f: integer*8 function i8glmax(a,n)
mpi_dummy.f: function mpi_wtick ( )
mpi_dummy.f: function mpi_wtime ( )
navier1.f:C Compute and add: (1) user specified forcing function (FX,FY,FZ)
navier1.f:C Compute and add: (1) user specified forcing function (FX,FY,FZ)
navier1.f:C Eulerian scheme, add convection term to forcing function
navier4.f: FUNCTION VLSC3(X,Y,B,N)
navier5.f: function facint(a,b,area,ifc,ie)
navier5.f: function facint2(a,b,c,area,ifc,ie)
navier5.f:c This routing builds a 1D filter with a transfer function that
navier5.f:c Set up transfer function
navier5.f: function ran1(idum)
navier7.f: function mbw_csr(ia,ja,n)
navier8.f: logical function iftuple_ialtb(a,b,key,nkey)
navier8.f: logical function iftuple_altb(a,b,key,nkey)
navier8.f: logical function iftuple_ianeb(a,b,key,nkey)
pertsupport.f: function opnormOld(v1,v2,v3,weight)
pertsupport.f: function opnorm2(v1,v2,v3)
pertsupport.f: function Tnorm(temp)
pertsupport.f: function dmnorm(v1,v2,v3,temp)
pertsupport.f: function pert_inner_prod(i,j) ! weighted inner product vi^T vj
perturb.f:c Compute and add: (1) user specified forcing function (FX,FY,FZ)
perturb.f:C Eulerian scheme, add convection term to forcing function
perturb.f:C Generate forcing function for the solution of a passive scalar.
perturb.f:C Fill up user defined forcing function and collocate will the
perturb.f:C Eulerian scheme, add convection term to forcing function
perturb.f: function pert_inner_prod(i,j) ! weighted inner product vi^T vj
perturb.f: function opnorm2(v1,v2,v3)
perturb.f: function Tnorm(temp)
perturb.f: function dmnorm(v1,v2,v3,temp)
postpro.f:c Build 1D-filter based on the transfer function (tf)
postpro.f:c This routing builds a 1D filter with transfer function diag()
prepost.f: FUNCTION SUMFC (FF,SM,IFC)
prepost.f: function i_find_prefix(prefix,imax)
speclib.f:C [2] Abramowitz & Stegun: Handbook of Mathematical Functions,
speclib.f: REAL*8 FUNCTION ENDW1 (N,ALPHA,BETA)
speclib.f: REAL*8 FUNCTION ENDW2 (N,ALPHA,BETA)
speclib.f: REAL*8 FUNCTION GAMMAF (X)
speclib.f: REAL*8 FUNCTION PNORMJ (N,ALPHA,BETA)
speclib.f: REAL FUNCTION HGJ (II,Z,ZGJ,NP,ALPHA,BETA)
speclib.f: REAL*8 FUNCTION HGJD (II,Z,ZGJ,NP,ALPHA,BETA)
speclib.f: REAL FUNCTION HGLJ (II,Z,ZGLJ,NP,ALPHA,BETA)
speclib.f: REAL*8 FUNCTION HGLJD (I,Z,ZGLJ,NP,ALPHA,BETA)
speclib.f: REAL FUNCTION HGLL (I,Z,ZGLL,NZ)
speclib.f: REAL FUNCTION HGL (I,Z,ZGL,NZ)
speclib.f: REAL FUNCTION PNLEG (Z,N)
speclib.f: REAL FUNCTION PNDLEG (Z,N)
subs1.f: FUNCTION FACDOT(A,B,IFACE1)
subs1.f:C 2 for fortran function;
subs1.f:C User specified fortran function (pff 2/13/01)
subs1.f:C User specified fortran function
subs1.f: function surf_mean(u,ifld,bc_in,ierr)
c-----------------------------------------------------------------------
subroutine q_filter(wght)
c
c filter vx,vy,vz, and p by simple interpolation
c
include 'SIZE'
include 'TOTAL'
c
c
c These are the dimensions that we interpolate onto for v and p:
parameter(lxv=lx1-1)
parameter(lxp=lx2-1)
c
real intdv(lx1,lx1)
real intuv(lx1,lx1)
real intdp(lx1,lx1)
real intup(lx1,lx1)
real intv(lx1,lx1)
real intp(lx1,lx1)
c
save intdv
save intuv
save intdp
save intup
save intv
save intp
common /ctmp0/ intw,intt
$ , wk1,wk2
$ , zgmv,wgtv,zgmp,wgtp,tmax(100),omax(103)
real intw(lx1,lx1)
real intt(lx1,lx1)
real wk1 (lx1,lx1,lx1,lelt)
real wk2 (lx1,lx1,lx1)
real zgmv(lx1),wgtv(lx1),zgmp(lx1),wgtp(lx1)
c
c outpost arrays
parameter (lt=lx1*ly1*lz1*lelv)
common /scruz/ w1(lt),w2(lt),w3(lt),wt(lt)
character*18 sfmt
integer icalld
save icalld
data icalld /0/
logical ifdmpflt
C
imax = nid
imax = iglmax(imax,1)
jmax = iglmax(imax,1)
if (icalld.eq.0) then
icalld = 1
ncut = param(101)+1
call build_new_filter(intv,zgm1,nx1,ncut,wght,nid)
elseif (icalld.lt.0) then ! old (std.) filter
icalld = 1
call zwgll(zgmv,wgtv,lxv)
call igllm(intuv,intw,zgmv,zgm1,lxv,nx1,lxv,nx1)
call igllm(intdv,intw,zgm1,zgmv,nx1,lxv,nx1,lxv)
c
call zwgl (zgmp,wgtp,lxp)
call iglm (intup,intw,zgmp,zgm2,lxp,nx2,lxp,nx2)
call iglm (intdp,intw,zgm2,zgmp,nx2,lxp,nx2,lxp)
c
c Multiply up and down interpolation into single operator
c
call mxm(intup,nx2,intdp,lxp,intp,nx2)
call mxm(intuv,nx1,intdv,lxv,intv,nx1)
c
c Weight the filter to make it a smooth (as opposed to truncated)
c decay in wave space
c
w0 = 1.-wght
call ident(intup,nx2)
call add2sxy(intp,wght,intup,w0,nx2*nx2)
c
call ident (intuv,nx1)
call add2sxy (intv ,wght,intuv,w0,nx1*nx1)
c
c if (nid.eq.0) call outmatx(intp,nx2,nx2,21,'flt2')
c if (nid.eq.0) call outmatx(zgm2 ,nx2,1 ,22,'zgm2')
c if (nid.eq.0) call outmatx(intv,nx1,nx1,11,'flt1')
c if (nid.eq.0) call outmatx(zgm1 ,nx1,1 ,12,'zgm1')
c
endif
c
c - - - - - - - - - - - - - - - - - - - - - -
c Check to see if we should dump U-F(U)
ifdmpflt = .false.
if (param(106).ne.0) then
i106 = param(106)
if (mod(istep,i106).eq.0) ifdmpflt = .true.
endif
c
if (ifdmpflt) then
call opcopy(w1,w2,w3,vx,vy,vz)
ntot = nx1*ny1*nz1*nelt
if (ifheat) call copy(wt,t,ntot)
endif
c - - - - - - - - - - - - - - - - - - - - - -
ifldt = ifield
c ifield = 1
if ( (ifflow.and. .not. ifmhd) .or.
$ (ifield.eq.1 .and. ifmhd) ) then
call filterq(vx,intv,nx1,nz1,wk1,wk2,intt,if3d,umax)
call filterq(vy,intv,nx1,nz1,wk1,wk2,intt,if3d,vmax)
if (if3d)
$ call filterq(vz,intv,nx1,nz1,wk1,wk2,intt,if3d,wmax)
if (ifsplit.and..not.iflomach)
$ call filterq(pr,intv,nx1,nz1,wk1,wk2,intt,if3d,pmax)
endif
c
if (ifmhd.and.ifield.eq.ifldmhd) then
call filterq(bx,intv,nx1,nz1,wk1,wk2,intt,if3d,umax)
call filterq(by,intv,nx1,nz1,wk1,wk2,intt,if3d,vmax)
if (if3d)
$ call filterq(bz,intv,nx1,nz1,wk1,wk2,intt,if3d,wmax)
endif
c
if (ifpert) then
do j=1,npert
ifield = 2
call filterq(vxp(1,j),intv,nx1,nz1,wk1,wk2,intt,if3d,umax)
call filterq(vyp(1,j),intv,nx1,nz1,wk1,wk2,intt,if3d,vmax)
if (if3d)
$ call filterq(vzp(1,j),intv,nx1,nz1,wk1,wk2,intt,if3d,wmax)
ifield = 1
if (ifheat .and. .not.ifcvode)
$ call filterq(tp(1,j,1),intv,nx1,nz1,wk1,wk2,intt,if3d,wmax)
enddo
endif
c
mmax = 0
if (ifflow) then
c pmax = glmax(pmax,1)
omax(1) = glmax(umax,1)
omax(2) = glmax(vmax,1)
omax(3) = glmax(wmax,1)
mmax = ndim
endif
c
nfldt = 1+npscal
if (ifheat .and. .not.ifcvode) then
do ifld=1,nfldt
ifield = ifld + 1
call filterq(t(1,1,1,1,ifld),intv
$ ,nx1,nz1,wk1,wk2,intt,if3d,tmax(ifld))
mmax = mmax+1
omax(mmax) = glmax(tmax(ifld),1)
enddo
endif
if (nid.eq.0) then
if (npscal.eq.0) then
c write(6,101) mmax
c write(sfmt,101) mmax
c 101 format('''(i8,1p',i1,'e12.4,a6)''')
c write(6,sfmt) istep,(omax(k),k=1,mmax),' qfilt'
c write(6,'(i8,1p4e12.4,a6)') istep,(omax(k),k=1,mmax),' qfilt'
else
if (if3d) then
write(6,1) istep,ifield,umax,vmax,wmax
else
write(6,1) istep,ifield,umax,vmax
endif
1 format(4x,i7,i3,' qfilt:',1p3e12.4)
if(ifheat .and. .not.ifcvode)
& write(6,'(1p50e12.4)') (tmax(k),k=1,nfldt)
endif
endif
c
c - - - - - - - - - - - - - - - - - - - - - -
c Check to see if we should dump U-F(U)
if (ifdmpflt) then
ntot1 = nx1*ny1*nz1*nelv
ntot2 = nx2*ny2*nz2*nelv
c
call opsub2(w1,w2,w3,vx,vy,vz)
call copy (wk1,pr,ntot2)
if (ifheat) call sub2(wt,t,ntot1)
c
call outpost2(w1,w2,w3,wk1,wt,1,'flt')
endif
c - - - - - - - - - - - - - - - - - - - - - -
c write(6,*) 'this is wght:',wght,param(103)
c call exitt
c
ifield = ifldt ! RESTORE ifield
return
end
c-----------------------------------------------------------------------
subroutine filterq(v,f,nx,nz,w1,w2,ft,if3d,dmax)
c
include 'SIZE'
include 'TSTEP'
real v(nx*nx*nz,nelt),w1(1),w2(1)
logical if3d
c
real f(nx,nx),ft(nx,nx)
c
integer e
c
call transpose(ft,nx,f,nx)
c
nxyz=nx*nx*nz
dmax = 0.
nel = nelfld(ifield)
if (if3d) then
do e=1,nel
c Filter
call copy(w2,v(1,e),nxyz)
call mxm(f,nx,w2,nx,w1,nx*nx)
i=1
j=1
do k=1,nx
call mxm(w1(i),nx,ft,nx,w2(j),nx)
i = i+nx*nx
j = j+nx*nx
enddo
call mxm (w2,nx*nx,ft,nx,w1,nx)
call sub3(w2,v(1,e),w1,nxyz)
call copy(v(1,e),w1,nxyz)
smax = vlamax(w2,nxyz)
dmax = max(dmax,abs(smax))
enddo
c
else
do e=1,nel
c Filter
call copy(w1,v(1,e),nxyz)
call mxm(f ,nx,w1,nx,w2,nx)
call mxm(w2,nx,ft,nx,w1,nx)
c
call sub3(w2,v(1,e),w1,nxyz)
call copy(v(1,e),w1,nxyz)
smax = vlamax(w2,nxyz)
dmax = max(dmax,abs(smax))
enddo
endif
c
return
end
c-----------------------------------------------------------------------
subroutine outmatx(a,m,n,io,name)
real a(m*n)
character*4 name
c
open(unit=io,file=name)
do i=1,m*n
write(io,1) a(i)
enddo
1 format(1p1e22.13)
close(unit=io)
c
return
end
c-----------------------------------------------------------------------
subroutine drag_calc(scale)
c
INCLUDE 'SIZE'
INCLUDE 'TOTAL'
c
common /scrns/ pm1(lx1,ly1,lz1,lelv)
$,vxx(lx1,ly1,lz1,lelv),vxy(lx1,ly1,lz1,lelv),vxz(lx1,ly1,lz1,lelv)
$,vyx(lx1,ly1,lz1,lelv),vyy(lx1,ly1,lz1,lelv),vyz(lx1,ly1,lz1,lelv)
common /scruz/
$ vzx(lx1,ly1,lz1,lelv),vzy(lx1,ly1,lz1,lelv),vzz(lx1,ly1,lz1,lelv)
$,one(lx1,ly1,lz1,lelv)
real work(1)
equivalence (work,one)
c
common /cdrag/ dragx(0:maxobj),dragy(0:maxobj),dragz(0:maxobj)
$ , momx(0:maxobj), momy(0:maxobj), momz(0:maxobj)
$ , dpdx_mean,dpdy_mean,dpdz_mean
real momx ,momy ,momz
c
common /tdrag/ drag(11)
real dragpx,dragpy,dragpz,dragvx,dragvy,dragvz
real momvx ,momvy ,momvz
real check1,check2
c
equivalence (dragpx,drag(1)),(dragpy,drag(2)),(dragpz,drag(3))
equivalence (dragvx,drag(4)),(dragvy,drag(5)),(dragvz,drag(6))
equivalence (momvx ,drag(7)),(momvy ,drag(8)),(momvz ,drag(9))
equivalence (check1,drag(10)),(check2,drag(11))
common /cvflow_r/ flow_rate,base_flow,domain_length,xsec
$ , scale_vf(3)
ntot1 = nx1*ny1*nz1*nelv
c Map pressure onto mesh 1 (vxx and vyy are used as work arrays)
call mappr(pm1,pr,vxx,vyy)
call rone (one,ntot1)
c
c Add mean_pressure_gradient.X to p:
if (param(55).ne.0) then
dpdx_mean = -scale_vf(1)
dpdy_mean = -scale_vf(2)
dpdz_mean = -scale_vf(3)
endif
call add2s2(pm1,xm1,dpdx_mean,ntot1) ! Doesn't work if object is cut by
call add2s2(pm1,ym1,dpdy_mean,ntot1) ! periodicboundary. In this case,
call add2s2(pm1,zm1,dpdz_mean,ntot1) ! set ._mean=0 and compensate in
c ! usrchk() [ pff 10/21/04 ].
c Compute du/dn
CALL DUDXYZ (vxx,vx,RXM1,SXM1,TXM1,JACM1,1,1)
CALL DUDXYZ (vxy,vx,RYM1,SYM1,TYM1,JACM1,1,1)
if (if3d) CALL DUDXYZ (vxz,vx,RZM1,SZM1,TZM1,JACM1,1,1)
c
CALL DUDXYZ (vyx,vy,RXM1,SXM1,TXM1,JACM1,1,1)
CALL DUDXYZ (vyy,vy,RYM1,SYM1,TYM1,JACM1,1,1)
if (if3d) CALL DUDXYZ (vyz,vy,RZM1,SZM1,TZM1,JACM1,1,1)
c
if (if3d) then
CALL DUDXYZ (vzx,vz,RXM1,SXM1,TXM1,JACM1,1,1)
CALL DUDXYZ (vzy,vz,RYM1,SYM1,TYM1,JACM1,1,1)
CALL DUDXYZ (vzz,vz,RZM1,SZM1,TZM1,JACM1,1,1)
endif
c
c Fill up viscous array w/ default
c
if (istep.lt.1) call cfill(vdiff,param(2),ntot1)
c
call col2(vxx,vdiff,ntot1)
call col2(vxy,vdiff,ntot1)
call col2(vxz,vdiff,ntot1)
call col2(vyx,vdiff,ntot1)
call col2(vyy,vdiff,ntot1)
call col2(vyz,vdiff,ntot1)
call col2(vzx,vdiff,ntot1)
call col2(vzy,vdiff,ntot1)
call col2(vzz,vdiff,ntot1)
c
dragxt=0.0
dragyt=0.0
dragzt=0.0
c
DO 100 II=1,NHIS
IF (HCODE(10,II).NE.'I') GOTO 100
IOBJ = LOCHIS(1,II)
MEMTOT = NMEMBER(IOBJ)
C
c
IF (HCODE(1,II).NE.' ' .OR. HCODE(2,II).NE.' ' .OR.
$ HCODE(3,II).NE.' ' ) THEN
IFIELD = 1
c
c---------------------------------------------------------------------------
c Compute drag for this object
c---------------------------------------------------------------------------
c
dragvx=0.0
dragvy=0.0
dragvz=0.0
dragpx=0.0
dragpy=0.0
dragpz=0.0
c
momvx=0.0
momvy=0.0
momvz=0.0
c
check1=0.0
check2=0.0
DO 50 MEM=1,MEMTOT
ISK = 0
IEG = OBJECT(IOBJ,MEM,1)
IFC = OBJECT(IOBJ,MEM,2)
IF (GLLNID(IEG).EQ.NID) THEN
C This processor has a contribution
IE = GLLEL(IEG)
c
c Pressure drag
check1=check1+facint(one,one,area,ifc,ie)
check2=check2+facint(one,uny,area,ifc,ie)
c
dragpx=dragpx+facint(pm1,unx,area,ifc,ie)
dragpy=dragpy+facint(pm1,uny,area,ifc,ie)
if (if3d) dragpz=dragpz+facint(pm1,unz,area,ifc,ie)
c
c Viscous drag
if (if3d) then
dragvx=dragvx+facint(vxx,unx,area,ifc,ie)
$ +facint(vxy,uny,area,ifc,ie)
$ +facint(vxz,unz,area,ifc,ie)
$ +facint(vxx,unx,area,ifc,ie)
$ +facint(vyx,uny,area,ifc,ie)
$ +facint(vzx,unz,area,ifc,ie)
dragvy=dragvy+facint(vyx,unx,area,ifc,ie)
$ +facint(vyy,uny,area,ifc,ie)
$ +facint(vyz,unz,area,ifc,ie)
$ +facint(vxy,unx,area,ifc,ie)
$ +facint(vyy,uny,area,ifc,ie)
$ +facint(vzy,unz,area,ifc,ie)
dragvz=dragvz+facint(vzx,unx,area,ifc,ie)
$ +facint(vzy,uny,area,ifc,ie)
$ +facint(vzz,unz,area,ifc,ie)
$ +facint(vxz,unx,area,ifc,ie)
$ +facint(vyz,uny,area,ifc,ie)
$ +facint(vzz,unz,area,ifc,ie)
c
momvx=momvx-facint2(vxy,unx,unz,area,ifc,ie)
$ -facint2(vyx,unx,unz,area,ifc,ie)
$ -facint2(vyy,uny,unz,area,ifc,ie)
$ -facint2(vyy,uny,unz,area,ifc,ie)
$ -facint2(vzy,unz,unz,area,ifc,ie)
$ -facint2(vyz,unz,unz,area,ifc,ie)
$ +facint2(vxz,unx,uny,area,ifc,ie)
$ +facint2(vzx,unx,uny,area,ifc,ie)
$ +facint2(vyz,uny,uny,area,ifc,ie)
$ +facint2(vzy,uny,uny,area,ifc,ie)
$ +facint2(vzz,unz,uny,area,ifc,ie)
$ +facint2(vzz,unz,uny,area,ifc,ie)
momvy=momvy+facint2(vxx,unx,unz,area,ifc,ie)
$ +facint2(vxx,unx,unz,area,ifc,ie)
$ +facint2(vyx,uny,unz,area,ifc,ie)
$ +facint2(vxy,uny,unz,area,ifc,ie)
$ +facint2(vzx,unz,unz,area,ifc,ie)
$ +facint2(vxz,unz,unz,area,ifc,ie)
$ -facint2(vxz,unx,unx,area,ifc,ie)
$ -facint2(vzx,unx,unx,area,ifc,ie)
$ -facint2(vyz,uny,unx,area,ifc,ie)
$ -facint2(vzy,uny,unx,area,ifc,ie)
$ -facint2(vzz,unz,unx,area,ifc,ie)
$ -facint2(vzz,unz,unx,area,ifc,ie)
momvz=momvz-facint2(vxx,unx,uny,area,ifc,ie)
$ -facint2(vxx,unx,uny,area,ifc,ie)
$ -facint2(vyx,uny,uny,area,ifc,ie)
$ -facint2(vxy,uny,uny,area,ifc,ie)
$ -facint2(vzx,unz,uny,area,ifc,ie)
$ -facint2(vxz,unz,uny,area,ifc,ie)
$ +facint2(vxy,unx,unx,area,ifc,ie)
$ +facint2(vyx,unx,unx,area,ifc,ie)
$ +facint2(vyy,uny,unx,area,ifc,ie)
$ +facint2(vyy,uny,unx,area,ifc,ie)
$ +facint2(vzy,unz,unx,area,ifc,ie)
$ +facint2(vyz,unz,unx,area,ifc,ie)
c
else
dragvx=dragvx+facint(vxx,unx,area,ifc,ie)
$ +facint(vxy,uny,area,ifc,ie)
dragvy=dragvy+facint(vyx,unx,area,ifc,ie)
$ +facint(vyy,uny,area,ifc,ie)
endif
ENDIF
50 CONTINUE
c
c Sum contributions from all processors
call gop(drag,work,'+ ',11)
dragvx = -dragvx
dragvy = -dragvy
dragvz = -dragvz
ENDIF
c
c Scale by user specified scale factor (for convenience)
c
dragvx = scale*dragvx
dragvy = scale*dragvy
dragvz = scale*dragvz
c
dragpx = scale*dragpx
dragpy = scale*dragpy
dragpz = scale*dragpz
c
dragx(iobj) = dragvx+dragpx
dragy(iobj) = dragvy+dragpy
dragz(iobj) = dragvz+dragpz
c
c
momx(iobj) = 0.5*momvx
momy(iobj) = 0.5*momvy
momz(iobj) = 0.5*momvz
c
dragxt = dragxt + dragx(iobj)
dragyt = dragyt + dragy(iobj)
dragzt = dragzt + dragz(iobj)
c
if (nid.eq.0.and.istep.eq.1)
$ write(6,*) 'drag_calc: scale=',scale
if (nid.eq.0) then
write(6,6) istep,time,dragx(iobj),dragpx,dragvx,'dragx',iobj
write(6,6) istep,time,dragy(iobj),dragpy,dragvy,'dragy',iobj
if (if3d)
$ write(6,6) istep,time,dragz(iobj),dragpz,dragvz,'dragz',iobj
c
c done by zly (3/17/03)
c if(if3d) then
c write(6,113) istep,time,momx,momy,momz
c else
c write(6,112) istep,time,momx,momy
c endif
c
endif
6 format(i8,1p4e15.7,2x,a5,i5)
112 format(i6,1p3e15.7,' momx')
113 format(i6,1p4e15.7,' momx')
if (istep.lt.10.and.nid.eq.0)
$ write(6,9) 'check:',check1,check2,dpdx_mean,istep
9 format(a6,1p3e16.8,i9)
c if (time.gt.1.0.and.dragx.gt.10.) call emerxit
100 continue
c
if (nid.eq.0) then
write(6,6) istep,time,dragxt,dragpx,dragvx,'drgxt',iobj
write(6,6) istep,time,dragyt,dragpy,dragvy,'drgyt',iobj
if (if3d)
$ write(6,6) istep,time,dragzt,dragpz,dragvz,'drgzt',iobj
endif
c
dragx(0) = dragxt
dragy(0) = dragyt
dragz(0) = dragzt
c
return
end
c-----------------------------------------------------------------------
subroutine mappr(pm1,pm2,pa,pb)
c
INCLUDE 'SIZE'
INCLUDE 'TOTAL'
real pm1(lx1,ly1,lz1,lelv),pm2(lx2,ly2,lz2,lelv)
$ ,pa (lx1,ly2,lz2) ,pb (lx1,ly1,lz2)
c
C Map the pressure onto the velocity mesh
C
NGLOB1 = NX1*NY1*NZ1*NELV
NYZ2 = NY2*NZ2
NXY1 = NX1*NY1
NXYZ = NX1*NY1*NZ1
C
IF (IFSPLIT) THEN
CALL COPY(PM1,PM2,NGLOB1)
ELSE
DO 1000 IEL=1,NELV
CALL MXM (IXM21,NX1,PM2(1,1,1,IEL),NX2,pa (1,1,1),NYZ2)
DO 100 IZ=1,NZ2
CALL MXM (PA(1,1,IZ),NX1,IYTM21,NY2,PB(1,1,IZ),NY1)
100 CONTINUE
CALL MXM (PB(1,1,1),NXY1,IZTM21,NZ2,PM1(1,1,1,IEL),NZ1)
1000 CONTINUE
C Average the pressure on elemental boundaries
IFIELD=1
CALL DSSUM (PM1,NX1,NY1,NZ1)
CALL COL2 (PM1,VMULT,NGLOB1)
ENDIF
C
C
return
end
c
c-----------------------------------------------------------------------
function facint(a,b,area,ifc,ie)
c
C
C Take the dot product of A and B on the surface IFACE1 of element IE.
C
C IFACE1 is in the preprocessor notation
C IFACE is the dssum notation.
C 5 Jan 1989 15:12:22 PFF
C
INCLUDE 'SIZE'
INCLUDE 'TOPOL'
DIMENSION A (LX1,LY1,LZ1,lelv)
$ ,B (lx1,lz1,6,lelv)
$ ,area (lx1,lz1,6,lelv)
C
C Set up counters
C
CALL DSSET(NX1,NY1,NZ1)
IFACE = EFACE1(IFC)
JS1 = SKPDAT(1,IFACE)
JF1 = SKPDAT(2,IFACE)
JSKIP1 = SKPDAT(3,IFACE)
JS2 = SKPDAT(4,IFACE)
JF2 = SKPDAT(5,IFACE)
JSKIP2 = SKPDAT(6,IFACE)
C
SUM=0.0
I = 0
DO 100 J2=JS2,JF2,JSKIP2
DO 100 J1=JS1,JF1,JSKIP1
I = I+1
SUM = SUM + A(J1,J2,1,ie)*B(I,1,ifc,ie)*area(I,1,ifc,ie)
c SUM = SUM + A(J1,J2,1,ie)*B(J1,J2,1,ie)*area(I,1,ifc,ie)
100 CONTINUE
C
facint = SUM
c
return
end
c-----------------------------------------------------------------------
function facint2(a,b,c,area,ifc,ie)
include 'SIZE'
include 'TOPOL'
dimension a (lx1,ly1,lz1,lelv)
$ , b (lx1,lz1,6,lelv)
$ , c (lx1,lz1,6,lelv)
$ , area (lx1,lz1,6,lelv)
call dsset(nx1,ny1,nz1)
iface = eface1(ifc)
js1 = skpdat(1,iface)
jf1 = skpdat(2,iface)
jskip1 = skpdat(3,iface)
js2 = skpdat(4,iface)
jf2 = skpdat(5,iface)
jskip2 = skpdat(6,iface)
sum=0.0
i=0
do j2=js2,jf2,jskip2
do j1=js1,jf1,jskip1
i=i+1
sum=sum+a(j1,j2,1,ie)*b(i,1,ifc,ie)*c(i,1,ifc,ie)
$ *area(i,1,ifc,ie)
end do
end do
facint2=sum
return
end
c-----------------------------------------------------------------------
subroutine out_csrmats(acsr,ia,ja,n,name9)
real acsr(1)
integer ia(1),ja(1)
c
character*9 name9
character*9 s(16)
c
nnz = ia(n+1)-ia(1)
c
write(6,1) name9,n,nnz
1 format(/,'CSR Mat:',a9,3x,'n =',i5,3x,'nnz =',i5,/)
c
n16 = min(n,16)
n29 = min(n,29)
do i=1,n29
call blank(s,9*16)
n1 = ia(i)
n2 = ia(i+1)-1
do jj=n1,n2
j = ja (jj)
a = acsr(jj)
if (a.ne.0..and.j.le.n16) write(s(j),9) a
enddo
write(6,16) (s(k),k=1,n16)
enddo
9 format(f9.4)
16 format(16a9)
c
return
end
c-----------------------------------------------------------------------
subroutine local_grad3(ur,us,ut,u,N,e,D,Dt)
c Output: ur,us,ut Input:u,N,e,D,Dt
real ur(0:N,0:N,0:N),us(0:N,0:N,0:N),ut(0:N,0:N,0:N)
real u (0:N,0:N,0:N,1)
real D (0:N,0:N),Dt(0:N,0:N)
integer e
c
m1 = N+1
m2 = m1*m1
c
call mxm(D ,m1,u(0,0,0,e),m1,ur,m2)
do k=0,N
call mxm(u(0,0,k,e),m1,Dt,m1,us(0,0,k),m1)
enddo
call mxm(u(0,0,0,e),m2,Dt,m1,ut,m1)
c
return
end
c-----------------------------------------------------------------------
subroutine local_grad2(ur,us,u,N,e,D,Dt)
c Output: ur,us Input:u,N,e,D,Dt
real ur(0:N,0:N),us(0:N,0:N)
real u (0:N,0:N,1)
real D (0:N,0:N),Dt(0:N,0:N)
integer e
c
m1 = N+1
c
call mxm(D ,m1,u(0,0,e),m1,ur,m1)
call mxm(u(0,0,e),m1,Dt,m1,us,m1)
c
return
end
c-----------------------------------------------------------------------
subroutine gradm1(ux,uy,uz,u)
c
c Compute gradient of T -- mesh 1 to mesh 1 (vel. to vel.)
c
include 'SIZE'
include 'DXYZ'
include 'GEOM'
include 'INPUT'
include 'TSTEP'
c
parameter (lxyz=lx1*ly1*lz1)
real ux(lxyz,1),uy(lxyz,1),uz(lxyz,1),u(lxyz,1)
common /ctmp1/ ur(lxyz),us(lxyz),ut(lxyz)
integer e
nxyz = nx1*ny1*nz1
ntot = nxyz*nelt
N = nx1-1
do e=1,nelt
if (if3d) then
call local_grad3(ur,us,ut,u,N,e,dxm1,dxtm1)
do i=1,lxyz
ux(i,e) = jacmi(i,e)*(ur(i)*rxm1(i,1,1,e)
$ + us(i)*sxm1(i,1,1,e)
$ + ut(i)*txm1(i,1,1,e) )
uy(i,e) = jacmi(i,e)*(ur(i)*rym1(i,1,1,e)
$ + us(i)*sym1(i,1,1,e)
$ + ut(i)*tym1(i,1,1,e) )
uz(i,e) = jacmi(i,e)*(ur(i)*rzm1(i,1,1,e)
$ + us(i)*szm1(i,1,1,e)
$ + ut(i)*tzm1(i,1,1,e) )
enddo
else
if (ifaxis) call setaxdy (ifrzer(e))
call local_grad2(ur,us,u,N,e,dxm1,dytm1)
do i=1,lxyz
ux(i,e) =jacmi(i,e)*(ur(i)*rxm1(i,1,1,e)
$ + us(i)*sxm1(i,1,1,e) )
uy(i,e) =jacmi(i,e)*(ur(i)*rym1(i,1,1,e)
$ + us(i)*sym1(i,1,1,e) )
enddo
endif
enddo
c
return
end
c-----------------------------------------------------------------------
subroutine outpost(v1,v2,v3,vp,vt,name3)
real v1(1),v2(1),v3(1),vp(1),vt(1)
character*3 name3
call outpost2(v1,v2,v3,vp,vt,1,name3)
return
end
c-----------------------------------------------------------------------
subroutine outpost2(v1,v2,v3,vp,vt,nfldt,name3)
include 'SIZE'
include 'SOLN'
include 'INPUT'
parameter(ltot1=lx1*ly1*lz1*lelt)
parameter(ltot2=lx2*ly2*lz2*lelv)
common /outtmp/ w1(ltot1),w2(ltot1),w3(ltot1),wp(ltot2)
& ,wt(ltot1,ldimt)
c
real v1(1),v2(1),v3(1),vp(1),vt(ltot1,1)
character*3 name3
logical if_save(ldimt)
c
ntot1 = nx1*ny1*nz1*nelv
ntot1t = nx1*ny1*nz1*nelt
ntot2 = nx2*ny2*nz2*nelv
if(nfldt.gt.ldimt) then
write(6,*) 'ABORT: outpost data too large (nfldt>ldimt)!'
call exitt
endif
c store solution
call copy(w1,vx,ntot1)
call copy(w2,vy,ntot1)
call copy(w3,vz,ntot1)
call copy(wp,pr,ntot2)
do i = 1,nfldt
call copy(wt(1,i),t(1,1,1,1,i),ntot1t)
enddo
c swap with data to dump
call copy(vx,v1,ntot1)
call copy(vy,v2,ntot1)
call copy(vz,v3,ntot1)
call copy(pr,vp,ntot2)
do i = 1,nfldt
call copy(t(1,1,1,1,i),vt(1,i),ntot1t)
enddo
c dump data
if_save(1) = ifto
ifto = .false.
if(nfldt.gt.0) ifto = .true.
do i = 1,ldimt-1
if_save(i+1) = ifpsco(i)
ifpsco(i) = .false.
if(i+1.le.nfldt) ifpsco(i) = .true.
enddo
if (nid.eq.0) write(6,*) 'calling prepost ',name3, nfldt
call prepost(.true.,name3)
ifto = if_save(1)
do i = 1,ldimt-1
ifpsco(i) = if_save(i+1)
enddo
c restore solution data
call copy(vx,w1,ntot1)
call copy(vy,w2,ntot1)
call copy(vz,w3,ntot1)
call copy(pr,wp,ntot2)
do i = 1,nfldt
call copy(t(1,1,1,1,i),wt(1,i),ntot1t)
enddo
return
end
c-----------------------------------------------------------------------
subroutine comp_vort3(vort,work1,work2,u,v,w)
c
include 'SIZE'
include 'TOTAL'
c
parameter(lt=lx1*ly1*lz1*lelv)
real vort(lt,3),work1(1),work2(1),u(1),v(1),w(1)
c
ntot = nx1*ny1*nz1*nelv
if (if3d) then
c work1=dw/dy ; work2=dv/dz
call dudxyz(work1,w,rym1,sym1,tym1,jacm1,1,2)
call dudxyz(work2,v,rzm1,szm1,tzm1,jacm1,1,3)
call sub3(vort(1,1),work1,work2,ntot)
c work1=du/dz ; work2=dw/dx
call dudxyz(work1,u,rzm1,szm1,tzm1,jacm1,1,3)
call dudxyz(work2,w,rxm1,sxm1,txm1,jacm1,1,1)
call sub3(vort(1,2),work1,work2,ntot)
c work1=dv/dx ; work2=du/dy
call dudxyz(work1,v,rxm1,sxm1,txm1,jacm1,1,1)
call dudxyz(work2,u,rym1,sym1,tym1,jacm1,1,2)
call sub3(vort(1,3),work1,work2,ntot)
else
c work1=dv/dx ; work2=du/dy
call dudxyz(work1,v,rxm1,sxm1,txm1,jacm1,1,1)
call dudxyz(work2,u,rym1,sym1,tym1,jacm1,1,2)
call sub3(vort,work1,work2,ntot)
endif
c
c Avg at bndry
c
ifielt = ifield
ifield = 1
if (if3d) then
do idim=1,ndim
call col2 (vort(1,idim),bm1,ntot)
call dssum (vort(1,idim),nx1,ny1,nz1)
call col2 (vort(1,idim),binvm1,ntot)
enddo
else
call col2 (vort,bm1,ntot)
call dssum (vort,nx1,ny1,nz1)
call col2 (vort,binvm1,ntot)
endif
ifield = ifielt
c
return
end
c-----------------------------------------------------------------------
subroutine surface_int(sint,sarea,a,ie,iface1)
C
include 'SIZE'
include 'GEOM'
include 'PARALLEL'
include 'TOPOL'
real a(lx1,ly1,lz1,1)
c
integer icalld
save icalld
data icalld/0/
logical ifpf
save ifpf
c
if (icalld.eq.0) then
icalld=icalld+1
if (skpdat(1,2).eq.nx1) then
c write(6,*) 'In surface_int, using pf version of skpdat.'
ifpf = .true.
else
c write(6,*) 'In surface_int, using std version of skpdat.'
ifpf = .false.
endif
endif
C
sarea = 0.
sint = 0.
C
call dsset(nx1,ny1,nz1)
iface = eface1(iface1)
c
c Check skpdat (because of difference in pf vs. commercial version...arrghh)
c
if (ifpf) then
c pf version
js1 = skpdat(1,iface)
jf1 = skpdat(2,iface)
jskip1 = skpdat(3,iface)
js2 = skpdat(4,iface)
jf2 = skpdat(5,iface)
jskip2 = skpdat(6,iface)
else
c std version
js1 = skpdat(iface,1)
jf1 = skpdat(iface,2)
jskip1 = skpdat(iface,3)
js2 = skpdat(iface,4)
jf2 = skpdat(iface,5)
jskip2 = skpdat(iface,6)
endif
C
I = 0
do 100 j2=js2,jf2,jskip2
do 100 j1=js1,jf1,jskip1
I = I+1
sarea = sarea+area(i,1,iface1,ie)
sint = sint +area(i,1,iface1,ie)*a(j1,j2,1,ie)
100 continue
C
return
end
c-----------------------------------------------------------------------
subroutine surface_flux(dq,qx,qy,qz,ie,iface,w)
C
include 'SIZE'
include 'GEOM'
include 'INPUT'
include 'PARALLEL'
include 'TOPOL'
parameter (l=lx1*ly1*lz1)
real w(lx1,ly1,lz1),qx(l,1),qy(l,1),qz(l,1)
c
integer icalld
save icalld
data icalld/0/
logical ifpf
save ifpf
c
call dsset(nx1,ny1,nz1)
if (icalld.eq.0) then
icalld=icalld+1
if (skpdat(1,2).eq.nx1) then
write(6,*) 'In surface_flux, using pf version of skpdat.'
ifpf = .true.
else
write(6,*) 'In surface_flux, using std version of skpdat.'
ifpf = .false.
endif
endif
C
ifacepf = eface1(iface)
c
c Check skpdat (because of difference in pf vs. commercial version...arrghh)
c
if (ifpf) then
c pf version
js1 = skpdat(1,ifacepf)
jf1 = skpdat(2,ifacepf)
jskip1 = skpdat(3,ifacepf)
js2 = skpdat(4,ifacepf)
jf2 = skpdat(5,ifacepf)
jskip2 = skpdat(6,ifacepf)
else
c std version
js1 = skpdat(ifacepf,1)
jf1 = skpdat(ifacepf,2)
jskip1 = skpdat(ifacepf,3)
js2 = skpdat(ifacepf,4)
jf2 = skpdat(ifacepf,5)
jskip2 = skpdat(ifacepf,6)
endif
C
call faccl3 (w,qx(1,ie),unx(1,1,iface,ie),iface)
call faddcl3(w,qy(1,ie),uny(1,1,iface,ie),iface)
if (if3d)
$call faddcl3(w,qz(1,ie),unz(1,1,iface,ie),iface)
c
dq = 0
i = 0
do 100 j2=js2,jf2,jskip2
do 100 j1=js1,jf1,jskip1
i = i+1
dq = dq +area(i,1,iface,ie)*w(j1,j2,1)
100 continue
C
return
end
c-----------------------------------------------------------------------
subroutine gaujordf(a,m,n,indr,indc,ipiv,ierr,rmult)
C
C Gauss-Jordan matrix inversion with full pivoting
c
c Num. Rec. p. 30, 2nd Ed., Fortran
c
C
C a is an m x n matrix
C rmult is a work array of dimension m
C
c
real a(m,n),rmult(m)
integer indr(m),indc(n),ipiv(n)
c call outmat(a,m,n,'ab4',n)
c do i=1,m
c write(6,1) (a(i,j),j=1,n)
c enddo
c 1 format('mat: ',1p6e12.4)
ierr = 0
eps = 1.e-9
call izero(ipiv,m)
do k=1,m
amx=0.
do i=1,m ! Pivot search
if (ipiv(i).ne.1) then
do j=1,m
if (ipiv(j).eq.0) then
if (abs(a(i,j)).ge.amx) then
amx = abs(a(i,j))
ir = i
jc = j
endif
elseif (ipiv(j).gt.1) then
ierr = -ipiv(j)
return
endif
enddo
endif
enddo
ipiv(jc) = ipiv(jc) + 1
c
c Swap rows
if (ir.ne.jc) then
do j=1,n
tmp = a(ir,j)
a(ir,j) = a(jc,j)
a(jc,j) = tmp
enddo
endif
indr(k)=ir
indc(k)=jc
c write(6 ,*) k,' Piv:',jc,a(jc,jc)
c write(28,*) k,' Piv:',jc,a(jc,jc)
if (abs(a(jc,jc)).lt.eps) then
write(6 ,*) 'small Gauss Jordan Piv:',jc,a(jc,jc)
write(28,*) 'small Gauss Jordan Piv:',jc,a(jc,jc)
ierr = jc
call exitt
return
endif
piv = 1./a(jc,jc)
a(jc,jc)=1.
do j=1,n
a(jc,j) = a(jc,j)*piv
enddo
c
do j=1,n
work = a(jc,j)
a(jc,j) = a(1 ,j)
a(1 ,j) = work
enddo
do i=2,m
rmult(i) = a(i,jc)
a(i,jc) = 0.
enddo
c
do j=1,n
do i=2,m
a(i,j) = a(i,j) - rmult(i)*a(1,j)
enddo
enddo
c
do j=1,n
work = a(jc,j)
a(jc,j) = a(1 ,j)
a(1 ,j) = work
enddo
c
c do i=1,m
c if (i.ne.jc) then
c rmult = a(i,jc)
c a(i,jc) = 0.
c do j=1,n
c a(i,j) = a(i,j) - rmult*a(jc,j)
c enddo
c endif
c enddo
c
enddo
c
c Unscramble matrix
do j=m,1,-1
if (indr(j).ne.indc(j)) then
do i=1,m
tmp=a(i,indr(j))
a(i,indr(j))=a(i,indc(j))
a(i,indc(j))=tmp
enddo
endif
enddo
c
return
end
c-----------------------------------------------------------------------
subroutine legendre_poly(L,x,N)
c
c Evaluate Legendre polynomials of degrees 0-N at point x
c
real L(0:N)
c
L(0) = 1.
L(1) = x
c
do j=2,N
L(j) = ( (2*j-1) * x * L(j-1) - (j-1) * L(j-2) ) / j
enddo
c
return
end
c-----------------------------------------------------------------------
subroutine build_new_filter(intv,zpts,nx,kut,wght,nid)
c
c This routing builds a 1D filter with a transfer function that
c looks like:
c
c
c ^
c d_k |
c | |
c 1 |__________ _v_
c | -_
c | \ wght
c | \ ___
c | | ^
c 0 |-------------|---|>
c
c 0 c N k-->
c
c Where c := N-kut is the point below which d_k = 1.
c
c
c
c Here, nx = number of points
c
real intv(nx,nx),zpts(nx)
c
parameter (lm=40)
parameter (lm2=lm*lm)
real phi(lm2),pht(lm2),diag(lm2),rmult(lm),Lj(lm)
integer indr(lm),indc(lm),ipiv(lm)
c
if (nx.gt.lm) then
write(6,*) 'ABORT in build_new_filter:',nx,lm
call exitt
endif
c
kj = 0
n = nx-1
do j=1,nx
z = zpts(j)
call legendre_poly(Lj,z,n)
kj = kj+1
pht(kj) = Lj(1)
kj = kj+1
pht(kj) = Lj(2)
do k=3,nx
kj = kj+1
pht(kj) = Lj(k)-Lj(k-2)
enddo
enddo
call transpose (phi,nx,pht,nx)
call copy (pht,phi,nx*nx)
call gaujordf (pht,nx,nx,indr,indc,ipiv,ierr,rmult)
c
c Set up transfer function
c
call ident (diag,nx)
c
k0 = nx-kut
do k=k0+1,nx
kk = k+nx*(k-1)
amp = wght*(k-k0)*(k-k0)/(kut*kut) ! quadratic growth
diag(kk) = 1.-amp
enddo
c
call mxm (diag,nx,pht,nx,intv,nx) ! -1
call mxm (phi ,nx,intv,nx,pht,nx) ! V D V
call copy (intv,pht,nx*nx)
c
do k=1,nx*nx
pht(k) = 1.-diag(k)
enddo
np1 = nx+1
if (nid.eq.0) then
write(6,6) 'filt amp',(pht (k),k=1,nx*nx,np1)
write(6,6) 'filt trn',(diag(k),k=1,nx*nx,np1)
6 format(a8,16f7.4,6(/,8x,16f7.4))
endif
c
return
end
c-----------------------------------------------------------------------
subroutine avg_all
c
c This routine computes running averages E(X),E(X^2),E(X*Y)
c and outputs to avg*.fld*, rms*.fld*, and rm2*.fld* for all
c fields.
c
c E denotes the expected value operator and X,Y two
c real valued random variables.
c
c variances and covariances can be computed in a post-processing step:
c
c var(X) := E(X^X) - E(X)*E(X)
c cov(X,Y) := E(X*Y) - E(X)*E(Y)
c
c Note: The E-operator is linear, in the sense that the expected
c value is given by E(X) = 1/N * sum[ E(X)_i ], where E(X)_i
c is the expected value of the sub-ensemble i (i=1...N).
c
include 'SIZE'
include 'TOTAL'
include 'AVG'
logical ifverbose
integer icalld
save icalld
data icalld /0/
if (ax1.ne.lx1 .or. ay1.ne.ly1 .or. az1.ne.lz1) then
if(nid.eq.0) write(6,*)
$ 'ABORT: wrong size of ax1,ay1,az1 in avg_all(), check SIZEu!'
call exitt
endif
if (ax2.ne.lx2 .or. ay2.ne.ay2 .or. az2.ne.lz2) then
if(nid.eq.0) write(6,*)
$ 'ABORT: wrong size of ax2,ay2,az2 in avg_all(), check SIZEu!'
call exitt
endif
ntot = nx1*ny1*nz1*nelv
ntott = nx1*ny1*nz1*nelt
nto2 = nx2*ny2*nz2*nelv
! initialization
if (icalld.eq.0) then
icalld = icalld + 1
atime = 0.
timel = time
call rzero(uavg,ntot)
call rzero(vavg,ntot)
call rzero(wavg,ntot)
call rzero(pavg,nto2)
do i = 1,ldimt
call rzero(tavg(1,1,1,1,i),ntott)
enddo
call rzero(urms,ntot)
call rzero(vrms,ntot)
call rzero(wrms,ntot)
call rzero(prms,nto2)
do i = 1,ldimt
call rzero(trms(1,1,1,1,i),ntott)
enddo
call rzero(vwms,ntot)
call rzero(wums,ntot)
call rzero(uvms,ntot)
endif
dtime = time - timel
atime = atime + dtime
! dump freq
iastep = param(68)
if (iastep.eq.0) iastep=param(15) ! same as iostep
if (iastep.eq.0) iastep=500
ifverbose=.false.
if (istep.le.10) ifverbose=.true.
if (mod(istep,iastep).eq.0) ifverbose=.true.
if (atime.ne.0..and.dtime.ne.0.) then
if(nid.eq.0) write(6,*) 'Compute statistics ...'
beta = dtime/atime
alpha = 1.-beta
! compute averages E(X)
call avg1 (uavg,vx,alpha,beta,ntot ,'um ',ifverbose)
call avg1 (vavg,vy,alpha,beta,ntot ,'vm ',ifverbose)
call avg1 (wavg,vz,alpha,beta,ntot ,'wm ',ifverbose)
call avg1 (pavg,pr,alpha,beta,nto2 ,'prm ',ifverbose)
call avg1 (tavg,t ,alpha,beta,ntott,'tm ',ifverbose)
do i = 2,ldimt
call avg1 (tavg(1,1,1,1,i),t(1,1,1,1,i),alpha,beta,
& ntott,'psav',ifverbose)
enddo
! compute averages E(X^2)
call avg2 (urms,vx,alpha,beta,ntot ,'ums ',ifverbose)
call avg2 (vrms,vy,alpha,beta,ntot ,'vms ',ifverbose)
call avg2 (wrms,vz,alpha,beta,ntot ,'wms ',ifverbose)
call avg2 (prms,pr,alpha,beta,nto2 ,'prms',ifverbose)
call avg2 (trms,t ,alpha,beta,ntott,'tms ',ifverbose)
do i = 2,ldimt
call avg2 (trms(1,1,1,1,i),t(1,1,1,1,i),alpha,beta,
& ntott,'psms',ifverbose)
enddo
! compute averages E(X*Y) (for now just for the velocities)
call avg3 (uvms,vx,vy,alpha,beta,ntot,'uvm ',ifverbose)
call avg3 (vwms,vy,vz,alpha,beta,ntot,'vwm ',ifverbose)
call avg3 (wums,vz,vx,alpha,beta,ntot,'wum ',ifverbose)
endif
c
c-----------------------------------------------------------------------
if ( (mod(istep,iastep).eq.0.and.istep.gt.1) .or.lastep.eq.1) then
time_temp = time
time = atime ! Output the duration of this avg
call outpost2(uavg,vavg,wavg,pavg,tavg,ldimt,'avg')
call outpost2(urms,vrms,wrms,prms,trms,ldimt,'rms')
call outpost2(uvms,vwms,wums,prms,wtms,0 ,'rm2')
atime = 0.
time = time_temp ! Restore clock
endif
c
timel = time
c
return
end
c-----------------------------------------------------------------------
subroutine avg1(avg,f,alpha,beta,n,name,ifverbose)
include 'SIZE'
include 'TSTEP'
c
real avg(n),f(n)
character*4 name
logical ifverbose
c
do k=1,n
avg(k) = alpha*avg(k) + beta*f(k)
enddo
c
if (ifverbose) then
avgmax = glmax(avg,n)
avgmin = glmin(avg,n)
if (nid.eq.0) write(6,1) istep,time,avgmin,avgmax
$ ,alpha,beta,name
1 format(i9,1p5e13.5,1x,a4,' av1mnx')
endif
c
return
end
c-----------------------------------------------------------------------
subroutine avg2(avg,f,alpha,beta,n,name,ifverbose)
include 'SIZE'
include 'TSTEP'
c
real avg(n),f(n)
character*4 name
logical ifverbose
c
do k=1,n
avg(k) = alpha*avg(k) + beta*f(k)*f(k)
enddo
c
if (ifverbose) then
avgmax = glmax(avg,n)
avgmin = glmin(avg,n)
if (nid.eq.0) write(6,1) istep,time,avgmin,avgmax
$ ,alpha,beta,name
1 format(i9,1p5e13.5,1x,a4,' av2mnx')
endif
c
return
end
c-----------------------------------------------------------------------
subroutine avg3(avg,f,g,alpha,beta,n,name,ifverbose)
include 'SIZE'
include 'TSTEP'
c
real avg(n),f(n),g(n)
character*4 name
logical ifverbose
c
do k=1,n
avg(k) = alpha*avg(k) + beta*f(k)*g(k)
enddo
c
if (ifverbose) then
avgmax = glmax(avg,n)
avgmin = glmin(avg,n)
if (nid.eq.0) write(6,1) istep,time,avgmin,avgmax
$ ,alpha,beta,name
1 format(i9,1p5e13.5,1x,a4,' av3mnx')
endif
c
return
end
c-----------------------------------------------------------------------
subroutine build_legend_transform(Lj,Ljt,zpts,nx)
c
real Lj(nx*nx),Ljt(nx*nx),zpts(nx)
c
parameter (lm=90)
integer indr(lm),indc(lm),ipiv(lm)
c
if (nx.gt.lm) then
write(6,*) 'ABORT in build_legend_transform:',nx,lm
call exitt
endif
c
j = 1
n = nx-1
do i=1,nx
z = zpts(i)
call legendre_poly(Lj(j),z,n) ! Return Lk(z), k=0,...,n
j = j+nx
enddo
call transpose1(Lj,nx)
c call outmat(Lj,nx,nx,'Lj ',n)
c call exitt
call gaujordf (Lj,nx,nx,indr,indc,ipiv,ierr,rmult)
call transpose (Ljt,nx,Lj,nx)
c
return
end
c-----------------------------------------------------------------------
subroutine local_err_est(err,u,nx,Lj,Ljt,uh,w,if3d)
c
c Local error estimates for u_e
c
include 'SIZE'
real err(5,2),u(1),uh(nx,nx,nx),w(1),Lj(1),Ljt(1)
logical if3d
c
call rzero(err,10)
c
nxyz = nx**ndim
utot = vlsc2(u,u,nxyz)
if (utot.eq.0) return
c
call tensr3(uh,nx,u,nx,Lj,Ljt,Ljt,w) ! Go to Legendre space
c
c
c Get energy in low modes
c
m = nx-2
c
if (if3d) then
amp2_l = 0.
do k=1,m
do j=1,m
do i=1,m
amp2_l = amp2_l + uh(i,j,k)**2
enddo
enddo
enddo
c
c Energy in each spatial direction
c
amp2_t = 0
do k=m+1,nx
do j=1,m
do i=1,m
amp2_t = amp2_t + uh(i,j,k)**2
enddo
enddo
enddo
c
amp2_s = 0
do k=1,m
do j=m+1,nx
do i=1,m
amp2_s = amp2_s + uh(i,j,k)**2
enddo
enddo
enddo
c
amp2_r = 0
do k=1,m
do j=1,m
do i=m+1,nx
amp2_r = amp2_r + uh(i,j,k)**2
enddo
enddo
enddo
c
amp2_h = 0
do k=m+1,nx
do j=m+1,nx
do i=m+1,nx
amp2_h = amp2_h + uh(i,j,k)**2
enddo
enddo
enddo
c
etot = amp2_l + amp2_r + amp2_s + amp2_t + amp2_h
c
relr = amp2_r / (amp2_r + amp2_l)
rels = amp2_s / (amp2_s + amp2_l)
relt = amp2_t / (amp2_t + amp2_l)
relh = (amp2_r + amp2_s + amp2_t + amp2_h) / etot
c
else
k = 1
amp2_l = 0.
do j=1,m
do i=1,m
amp2_l = amp2_l + uh(i,j,k)**2
enddo
enddo
if (amp2_l.eq.0) return
c
c Energy in each spatial direction
c
amp2_t = 0
c
amp2_s = 0
do j=m+1,nx
do i=1,m
amp2_s = amp2_s + uh(i,j,k)**2
enddo
enddo
c
amp2_r = 0
do j=1,m
do i=m+1,nx
amp2_r = amp2_r + uh(i,j,k)**2
enddo
enddo
c
amp2_h = 0
do j=m+1,nx
do i=m+1,nx
amp2_h = amp2_h + uh(i,j,k)**2
enddo
enddo
c
etot = amp2_l + amp2_r + amp2_s + amp2_h
c
relr = amp2_r / (amp2_r + amp2_l)
rels = amp2_s / (amp2_s + amp2_l)
relt = 0
relh = (amp2_r + amp2_s + amp2_h) / etot
c
endif
c
err (1,1) = sqrt(relr)
err (2,1) = sqrt(rels)
if (if3d) err (3,1) = sqrt(relt)
err (4,1) = sqrt(relh)
err (5,1) = sqrt(etot)
c
err (1,2) = sqrt(amp2_r)
err (2,2) = sqrt(amp2_s)
if (if3d) err (3,2) = sqrt(amp2_t)
err (4,2) = sqrt(amp2_h)
err (5,2) = sqrt(utot)
c
return
end
c-----------------------------------------------------------------------
subroutine transpose1(a,n)
real a(n,n)
c
do j=1,n
do i=j+1,n
ta = a(i,j)
a(i,j) = a(j,i)
a(j,i) = ta
enddo
enddo
return
end
c-----------------------------------------------------------------------
subroutine get_exyz(ex,ey,ez,eg,nelx,nely,nelz)
integer ex,ey,ez,eg
c
nelxy = nelx*nely
c
ez = 1 + (eg-1)/nelxy
ey = mod1 (eg,nelxy)
ey = 1 + (ey-1)/nelx
ex = mod1 (eg,nelx)
c
return
end
c-----------------------------------------------------------------------
subroutine dump_header2d(excode,nx,ny,nlx,nly)
c
include 'SIZE'
include 'TOTAL'
c
character*2 excode(15)
c
real*4 test_pattern
c
character*1 fhdfle1(132)
character*132 fhdfle
equivalence (fhdfle,fhdfle1)
c
jstep = istep
if (jstep.gt.10000) jstep = jstep / 10
if (jstep.gt.10000) jstep = jstep / 10
if (jstep.gt.10000) jstep = jstep / 10
if (jstep.gt.10000) jstep = jstep / 10
if (jstep.gt.10000) jstep = jstep / 10
nlxy = nlx*nly
nzz = 1
c write(6,'(4i4,1PE14.7,i5,1x,15a2,1x,a12)')
c $ nlxy,nx,ny,nzz,TIME,jstep,(excode(i),i=1,15),
c $ 'NELT,NX,NY,N'
c
p66 = 0.
IF (p66.EQ.1.0) THEN
C unformatted i/o
WRITE(24)
$ nlxy,nx,ny,nzz,TIME,jstep,(excode(i),i=1,15)
ELSEIF (p66.EQ.3.0) THEN
C formatted i/o to header file
WRITE(27,'(4I4,1pe14.7,I5,1X,15A2,1X,A12)')
$ nlxy,nx,ny,nzz,TIME,jstep,(excode(i),i=1,15),
$ 'NELT,NX,NY,N'
ELSEIF (p66.eq.4.0) THEN
C formatted i/o to header file
WRITE(fhdfle,'(4I4,1pe14.7,I5,1X,15A2,1X,A12)')
$ nlxy,nx,ny,nzz,TIME,jstep,(excode(i),i=1,15),
$ ' 4 NELT,NX,NY,N'
call byte_write(fhdfle,20)
ELSEIF (p66.eq.5.0) THEN
C formatted i/o to header file
WRITE(fhdfle,'(4I4,1pe14.7,I5,1X,15A2,1X,A12)')
$ nlxy,nx,ny,nzz,TIME,jstep,(excode(i),i=1,15),
$ ' 8 NELT,NX,NY,N'
call byte_write(fhdfle,20)
ELSE
C formatted i/o
WRITE(24,'(4I4,1pe14.7,I5,1X,15A2,1X,A12)')
$ nlxy,nx,ny,nzz,TIME,jstep,(excode(i),i=1,15),
$ 'NELT,NX,NY,N'
ENDIF
C cdrror is a dummy cerror value for now.
CDRROR=0.0
IF (p66.EQ.1.0) THEN
C unformatted i/o
WRITE(24)(CDRROR,I=1,nlxy)
ELSEIF (p66.eq.3. .or. p66.eq.4.0) then
C write byte-ordering test pattern to byte file...
test_pattern = 6.54321
call byte_write(test_pattern,1)
ELSEIF (p66.eq.5.) then
test_pattern8 = 6.54321
call byte_write(test_pattern8,2)
ELSE
C formatted i/o
WRITE(24,'(6G11.4)')(CDRROR,I=1,nlxy)
ENDIF
c
return
end
c-----------------------------------------------------------------------
subroutine outfld2d_p(u,v,w,nx,ny,nlx,nly,name,ifld,jid,npido)
include 'SIZE'
include 'TOTAL'
integer icalld
save icalld
data icalld /0/
real u(nx*ny*nlx*nly)
real v(nx*ny*nlx*nly)
real w(nx*ny*nlx*nly)
character*4 name
character*2 excode(15)
character*12 fm
character*20 outfile
character*1 slash,dot
save slash,dot
data slash,dot / '/' , '.' /
icalld = icalld+1
call blank(excode,30)
excode(4) = 'U '
excode(5) = ' '
excode(6) = 'T '
nthings = 3
call blank(outfile,20)
if (npido.lt.100) then
if (ifld.lt.100) then
write(outfile,22) jid,slash,name,ifld
22 format('B',i2.2,a1,a4,'.fld',i2.2)
elseif (ifld.lt.1000) then
write(outfile,23) jid,slash,name,ifld
23 format('B',i2.2,a1,a4,'.fld',i3)
elseif (ifld.lt.10000) then
write(outfile,24) jid,slash,name,ifld
24 format('B',i2.2,a1,a4,'.fld',i4)
elseif (ifld.lt.100000) then
write(outfile,25) jid,slash,name,ifld
25 format('B',i2.2,a1,a4,'.fld',i5)
elseif (ifld.lt.1000000) then
write(outfile,26) jid,slash,name,ifld
26 format('B',i2.2,a1,a4,'.fld',i6)
endif
else
if (ifld.lt.100) then
write(outfile,32) jid,slash,name,ifld
32 format('B',i3.3,a1,a4,'.fld',i2.2)
elseif (ifld.lt.1000) then
write(outfile,33) jid,slash,name,ifld
33 format('B',i3.3,a1,a4,'.fld',i3)
elseif (ifld.lt.10000) then
write(outfile,34) jid,slash,name,ifld
34 format('B',i3.3,a1,a4,'.fld',i4)
elseif (ifld.lt.100000) then
write(outfile,35) jid,slash,name,ifld
35 format('B',i3.3,a1,a4,'.fld',i5)
elseif (ifld.lt.1000000) then
write(outfile,36) jid,slash,name,ifld
36 format('B',i3.3,a1,a4,'.fld',i6)
endif
endif
if (icalld.le.4) write(6,*) nid,outfile,' OPEN',nlx,nly
open(unit=24,file=outfile,status='unknown')
call dump_header2d(excode,nx,ny,nlx,nly)
n = nx*ny*nlx*nly
write(fm,10) nthings
write(24,fm) (u(i),v(i),w(i),i=1,n)
10 format('(1p',i1,'e14.6)')
close(24)
return
end
c-----------------------------------------------------------------------
subroutine outfld2d(u,v,w,nx,ny,nlx,nly,name,ifld)
c
include 'SIZE'
include 'TOTAL'
c
real u(nx*ny*nlx*nly)
real v(nx*ny*nlx*nly)
real w(nx*ny*nlx*nly)
character*3 name
c
character*2 excode(15)
character*12 fm
character*20 outfile
c if (istep.le.10) write(6,*) nid,' in out2d:',iz
c
call blank(excode,30)
c
c excode(1) = 'X '
c excode(2) = 'Y '
c excode(3) = 'U '
c excode(4) = 'V '
c excode(5) = 'P '
c excode(6) = 'T '
c
excode(4) = 'U '
excode(5) = ' '
excode(6) = 'T '
nthings = 3
c
if (nid.eq.0) then
call blank(outfile,20)
if (ifld.lt.100) then
write(outfile,2) name,ifld
2 format(a3,'2d.fld',i2.2)
elseif (ifld.lt.1000) then
write(outfile,3) name,ifld
3 format(a3,'2d.fld',i3)
elseif (ifld.lt.10000) then
write(outfile,4) name,ifld
4 format(a3,'2d.fld',i4)
elseif (ifld.lt.100000) then
write(outfile,5) name,ifld
5 format(a3,'2d.fld',i5)
elseif (ifld.lt.1000000) then
write(outfile,6) name,ifld
6 format(a3,'2d.fld',i6)
endif
open(unit=24,file=outfile,status='unknown')
call dump_header2d(excode,nx,ny,nlx,nly)
c
n = nx*ny*nlx*nly
write(fm,10) nthings
c write(6,*) fm
c call exitt
write(24,fm) (u(i),v(i),w(i),i=1,n)
10 format('(1p',i1,'e14.6)')
c 10 format('''(1p',i1,'e15.7)''')
c 10 format(1p7e15.7)
c
close(24)
endif
c
return
end
c-----------------------------------------------------------------------
subroutine planar_average_z(ua,u,w1,w2)
c
c Compute r-s planar average of quantity u()
c
include 'SIZE'
include 'GEOM'
include 'PARALLEL'
include 'WZ'
include 'ZPER'
c
real ua(nz1,nelz),u(nx1*ny1,nz1,nelv),w1(nz1,nelz),w2(nz1,nelz)
integer e,eg,ez
c
melxy = nelx*nely
c
nz = nz1*nelz
call rzero(ua,nz)
call rzero(w1,nz)
c
do e=1,nelt
c
eg = lglel(e)
ez = 1 + (eg-1)/melxy
c
do k=1,nz1
do i=1,nx1*ny1
zz = (1.-zgm1(k,3))/2. ! = 1 for k=1, = 0 for k=nz1
aa = zz*area(i,1,5,e) + (1-zz)*area(i,1,6,e) ! wgtd jacobian
w1(k,ez) = w1(k,ez) + aa
ua(k,ez) = ua(k,ez) + aa*u(i,k,e)
enddo
enddo
enddo
c
call gop(ua,w2,'+ ',nz)
call gop(w1,w2,'+ ',nz)
c
do i=1,nz
ua(i,1) = ua(i,1) / w1(i,1) ! Normalize
enddo
c
return
end
c-----------------------------------------------------------------------
subroutine drgtrq(dgtq,xm0,ym0,zm0,sij,pm1,visc,f,e)
c
INCLUDE 'SIZE'
INCLUDE 'GEOM'
INCLUDE 'INPUT'
INCLUDE 'TOPOL'
INCLUDE 'TSTEP'
c
real dgtq(3,4)
real xm0 (lx1,ly1,lz1,lelt)
real ym0 (lx1,ly1,lz1,lelt)
real zm0 (lx1,ly1,lz1,lelt)
real sij (lx1,ly1,lz1,3*ldim-3,lelv)
real pm1 (lx1,ly1,lz1,lelv)
real visc(lx1,ly1,lz1,lelv)
c
real dg(3,2)
c
integer f,e,pf
real n1,n2,n3
c
call dsset(nx1,ny1,nz1) ! set up counters
pf = eface1(f) ! convert from preproc. notation
js1 = skpdat(1,pf)
jf1 = skpdat(2,pf)
jskip1 = skpdat(3,pf)
js2 = skpdat(4,pf)
jf2 = skpdat(5,pf)
jskip2 = skpdat(6,pf)
C
call rzero(dgtq,12)
c
if (if3d.or.ifaxis) then
i = 0
a = 0
do j2=js2,jf2,jskip2
do j1=js1,jf1,jskip1
i = i+1
n1 = unx(i,1,f,e)*area(i,1,f,e)
n2 = uny(i,1,f,e)*area(i,1,f,e)
n3 = unz(i,1,f,e)*area(i,1,f,e)
a = a + area(i,1,f,e)
c
v = visc(j1,j2,1,e)
c
s11 = sij(j1,j2,1,1,e)
s21 = sij(j1,j2,1,4,e)
s31 = sij(j1,j2,1,6,e)
c
s12 = sij(j1,j2,1,4,e)
s22 = sij(j1,j2,1,2,e)
s32 = sij(j1,j2,1,5,e)
c
s13 = sij(j1,j2,1,6,e)
s23 = sij(j1,j2,1,5,e)
s33 = sij(j1,j2,1,3,e)
c
dg(1,1) = pm1(j1,j2,1,e)*n1 ! pressure drag
dg(2,1) = pm1(j1,j2,1,e)*n2
dg(3,1) = pm1(j1,j2,1,e)*n3
c
dg(1,2) = -v*(s11*n1 + s12*n2 + s13*n3) ! viscous drag
dg(2,2) = -v*(s21*n1 + s22*n2 + s23*n3)
dg(3,2) = -v*(s31*n1 + s32*n2 + s33*n3)
c
r1 = xm0(j1,j2,1,e)
r2 = ym0(j1,j2,1,e)
r3 = zm0(j1,j2,1,e)
c
do l=1,2
do k=1,3
dgtq(k,l) = dgtq(k,l) + dg(k,l)
enddo
enddo
c
dgtq(1,3) = dgtq(1,3) + (r2*dg(3,1)-r3*dg(2,1)) ! pressure
dgtq(2,3) = dgtq(2,3) + (r3*dg(1,1)-r1*dg(3,1)) ! torque
dgtq(3,3) = dgtq(3,3) + (r1*dg(2,1)-r2*dg(1,1))
c
dgtq(1,4) = dgtq(1,4) + (r2*dg(3,2)-r3*dg(2,2)) ! viscous
dgtq(2,4) = dgtq(2,4) + (r3*dg(1,2)-r1*dg(3,2)) ! torque
dgtq(3,4) = dgtq(3,4) + (r1*dg(2,2)-r2*dg(1,2))
enddo
enddo
else ! 2D
i = 0
a = 0
do j2=js2,jf2,jskip2
do j1=js1,jf1,jskip1
i = i+1
n1 = unx(i,1,f,e)*area(i,1,f,e)
n2 = uny(i,1,f,e)*area(i,1,f,e)
a = a + area(i,1,f,e)
v = visc(j1,j2,1,e)
s11 = sij(j1,j2,1,1,e)
s12 = sij(j1,j2,1,3,e)
s21 = sij(j1,j2,1,3,e)
s22 = sij(j1,j2,1,2,e)
dg(1,1) = pm1(j1,j2,1,e)*n1 ! pressure drag
dg(2,1) = pm1(j1,j2,1,e)*n2
dg(3,1) = 0
dg(1,2) = -v*(s11*n1 + s12*n2) ! viscous drag
dg(2,2) = -v*(s21*n1 + s22*n2)
dg(3,2) = 0.
r1 = xm0(j1,j2,1,e)
r2 = ym0(j1,j2,1,e)
r3 = 0.
do l=1,2
do k=1,3
dgtq(k,l) = dgtq(k,l) + dg(k,l)
enddo
enddo
dgtq(1,3) = 0! dgtq(1,3) + (r2*dg(3,1)-r3*dg(2,1)) ! pressure
dgtq(2,3) = 0! dgtq(2,3) + (r3*dg(1,1)-r1*dg(3,1)) ! torque
dgtq(3,3) = dgtq(3,3) + (r1*dg(2,1)-r2*dg(1,1))
dgtq(1,4) = 0! dgtq(1,4) + (r2*dg(3,2)-r3*dg(2,2)) ! viscous
dgtq(2,4) = 0! dgtq(2,4) + (r3*dg(1,2)-r1*dg(3,2)) ! torque
dgtq(3,4) = dgtq(3,4) + (r1*dg(2,2)-r2*dg(1,2))
enddo
enddo
endif
return
end
c-----------------------------------------------------------------------
subroutine torque_calc(scale,x0,ifdout,iftout)
c
c Compute torque about point x0
c
c Scale is a user-supplied multiplier so that results may be
c scaled to any convenient non-dimensionalization.
c
c
INCLUDE 'SIZE'
INCLUDE 'TOTAL'
common /cvflow_r/ flow_rate,base_flow,domain_length,xsec
$ , scale_vf(3)
c
real x0(3),w1(0:maxobj)
logical ifdout,iftout
c
common /scrns/ sij (lx1*ly1*lz1*6*lelv)
common /scrcg/ pm1 (lx1,ly1,lz1,lelv)
common /scrsf/ xm0(lx1,ly1,lz1,lelt)
$, ym0(lx1,ly1,lz1,lelt)
$, zm0(lx1,ly1,lz1,lelt)
c
parameter (lr=lx1*ly1*lz1)
common /scruz/ ur(lr),us(lr),ut(lr)
$ , vr(lr),vs(lr),vt(lr)
$ , wr(lr),ws(lr),wt(lr)
c
common /ctorq/ dragx(0:maxobj),dragpx(0:maxobj),dragvx(0:maxobj)
$ , dragy(0:maxobj),dragpy(0:maxobj),dragvy(0:maxobj)
$ , dragz(0:maxobj),dragpz(0:maxobj),dragvz(0:maxobj)
c
$ , torqx(0:maxobj),torqpx(0:maxobj),torqvx(0:maxobj)
$ , torqy(0:maxobj),torqpy(0:maxobj),torqvy(0:maxobj)
$ , torqz(0:maxobj),torqpz(0:maxobj),torqvz(0:maxobj)
c
$ , dpdx_mean,dpdy_mean,dpdz_mean
$ , dgtq(3,4)
c
c
n = nx1*ny1*nz1*nelv
c
call mappr(pm1,pr,xm0,ym0) ! map pressure onto Mesh 1
c
c Add mean_pressure_gradient.X to p:
if (param(55).ne.0) then
dpdx_mean = -scale_vf(1)
dpdy_mean = -scale_vf(2)
dpdz_mean = -scale_vf(3)
endif
call add2s2(pm1,xm1,dpdx_mean,n) ! Doesn't work if object is cut by
call add2s2(pm1,ym1,dpdy_mean,n) ! periodicboundary. In this case,
call add2s2(pm1,zm1,dpdz_mean,n) ! set ._mean=0 and compensate in
c
c Compute sij
c
nij = 3
if (if3d.or.ifaxis) nij=6
call comp_sij(sij,nij,vx,vy,vz,ur,us,ut,vr,vs,vt,wr,ws,wt)
c
c
c Fill up viscous array w/ default
c
if (istep.lt.1) call cfill(vdiff,param(2),n)
c
call cadd2(xm0,xm1,-x0(1),n)
call cadd2(ym0,ym1,-x0(2),n)
call cadd2(zm0,zm1,-x0(3),n)
c
x1min=glmin(xm0(1,1,1,1),n)
x2min=glmin(ym0(1,1,1,1),n)
x3min=glmin(zm0(1,1,1,1),n)
c
x1max=glmax(xm0(1,1,1,1),n)
x2max=glmax(ym0(1,1,1,1),n)
x3max=glmax(zm0(1,1,1,1),n)
c
do i=0,maxobj
dragpx(i) = 0 ! BIG CODE :}
dragvx(i) = 0
dragx (i) = 0
dragpy(i) = 0
dragvy(i) = 0
dragy (i) = 0
dragpz(i) = 0
dragvz(i) = 0
dragz (i) = 0
torqpx(i) = 0
torqvx(i) = 0
torqx (i) = 0
torqpy(i) = 0
torqvy(i) = 0
torqy (i) = 0
torqpz(i) = 0
torqvz(i) = 0
torqz (i) = 0
enddo
c
c
nobj = 0
do ii=1,nhis
if (hcode(10,ii).EQ.'I') then
iobj = lochis(1,ii)
memtot = nmember(iobj)
nobj = max(iobj,nobj)
c
if (hcode(1,ii).ne.' ' .or. hcode(2,ii).ne.' ' .or.
$ hcode(3,ii).ne.' ' ) then
ifield = 1
c
c Compute drag for this object
c
do mem=1,memtot
ieg = object(iobj,mem,1)
ifc = object(iobj,mem,2)
if (gllnid(ieg).eq.nid) then ! this processor has a contribution
ie = gllel(ieg)
call drgtrq(dgtq,xm0,ym0,zm0,sij,pm1,vdiff,ifc,ie)
c
call cmult(dgtq,scale,12)
c
dragpx(iobj) = dragpx(iobj) + dgtq(1,1) ! pressure
dragpy(iobj) = dragpy(iobj) + dgtq(2,1)
dragpz(iobj) = dragpz(iobj) + dgtq(3,1)
c
dragvx(iobj) = dragvx(iobj) + dgtq(1,2) ! viscous
dragvy(iobj) = dragvy(iobj) + dgtq(2,2)
dragvz(iobj) = dragvz(iobj) + dgtq(3,2)
c
torqpx(iobj) = torqpx(iobj) + dgtq(1,3) ! pressure
torqpy(iobj) = torqpy(iobj) + dgtq(2,3)
torqpz(iobj) = torqpz(iobj) + dgtq(3,3)
c
torqvx(iobj) = torqvx(iobj) + dgtq(1,4) ! viscous
torqvy(iobj) = torqvy(iobj) + dgtq(2,4)
torqvz(iobj) = torqvz(iobj) + dgtq(3,4)
c
endif
enddo
endif
endif
enddo
c
c Sum contributions from all processors
c
call gop(dragpx,w1,'+ ',maxobj+1)
call gop(dragpy,w1,'+ ',maxobj+1)
call gop(dragpz,w1,'+ ',maxobj+1)
call gop(dragvx,w1,'+ ',maxobj+1)
call gop(dragvy,w1,'+ ',maxobj+1)
call gop(dragvz,w1,'+ ',maxobj+1)
c
call gop(torqpx,w1,'+ ',maxobj+1)
call gop(torqpy,w1,'+ ',maxobj+1)
call gop(torqpz,w1,'+ ',maxobj+1)
call gop(torqvx,w1,'+ ',maxobj+1)
call gop(torqvy,w1,'+ ',maxobj+1)
call gop(torqvz,w1,'+ ',maxobj+1)
c
nobj = iglmax(nobj,1)
c
do i=1,nobj
dragx(i) = dragpx(i) + dragvx(i)
dragy(i) = dragpy(i) + dragvy(i)
dragz(i) = dragpz(i) + dragvz(i)
c
torqx(i) = torqpx(i) + torqvx(i)
torqy(i) = torqpy(i) + torqvy(i)
torqz(i) = torqpz(i) + torqvz(i)
c
dragpx(0) = dragpx (0) + dragpx (i)
dragvx(0) = dragvx (0) + dragvx (i)
dragx (0) = dragx (0) + dragx (i)
c
dragpy(0) = dragpy (0) + dragpy (i)
dragvy(0) = dragvy (0) + dragvy (i)
dragy (0) = dragy (0) + dragy (i)
c
dragpz(0) = dragpz (0) + dragpz (i)
dragvz(0) = dragvz (0) + dragvz (i)
dragz (0) = dragz (0) + dragz (i)
c
torqpx(0) = torqpx (0) + torqpx (i)
torqvx(0) = torqvx (0) + torqvx (i)
torqx (0) = torqx (0) + torqx (i)
c
torqpy(0) = torqpy (0) + torqpy (i)
torqvy(0) = torqvy (0) + torqvy (i)
torqy (0) = torqy (0) + torqy (i)
c
torqpz(0) = torqpz (0) + torqpz (i)
torqvz(0) = torqvz (0) + torqvz (i)
torqz (0) = torqz (0) + torqz (i)
c
enddo
c
i0 = 0
if (nobj.le.1) i0 = 1 ! one output for single-object case
c
do i=i0,nobj
if (nid.eq.0) then
if (if3d.or.ifaxis) then
if (ifdout) then
write(6,6) istep,time,dragx(i),dragpx(i),dragvx(i),i,'dragx'
write(6,6) istep,time,dragy(i),dragpy(i),dragvy(i),i,'dragy'
write(6,6) istep,time,dragz(i),dragpz(i),dragvz(i),i,'dragz'
endif
if (iftout) then
write(6,6) istep,time,torqx(i),torqpx(i),torqvx(i),i,'torqx'
write(6,6) istep,time,torqy(i),torqpy(i),torqvy(i),i,'torqy'
write(6,6) istep,time,torqz(i),torqpz(i),torqvz(i),i,'torqz'
endif
else
if (ifdout) then
write(6,6) istep,time,dragx(i),dragpx(i),dragvx(i),i,'dragx'
write(6,6) istep,time,dragy(i),dragpy(i),dragvy(i),i,'dragy'
endif
if (iftout) then
write(6,6) istep,time,torqz(i),torqpz(i),torqvz(i),i,'torqz'
endif
endif
endif
6 format(i8,1p4e15.7,2x,i5,a5)
enddo
c
return
end
c-----------------------------------------------------------------------
subroutine comp_sij(sij,nij,u,v,w,ur,us,ut,vr,vs,vt,wr,ws,wt)
c du_i du_j
c Compute the stress tensor S_ij := ---- + ----
c du_j du_i
c
include 'SIZE'
include 'TOTAL'
c
integer e
c
real sij(lx1*ly1*lz1,nij,lelv)
real u (lx1*ly1*lz1,lelv)
real v (lx1*ly1*lz1,lelv)
real w (lx1*ly1*lz1,lelv)
real ur (1) , us (1) , ut (1)
$ , vr (1) , vs (1) , vt (1)
$ , wr (1) , ws (1) , wt (1)
n = nx1-1 ! Polynomial degree
nxyz = nx1*ny1*nz1
if (if3d) then ! 3D CASE
do e=1,nelv
call local_grad3(ur,us,ut,u,N,e,dxm1,dxtm1)
call local_grad3(vr,vs,vt,v,N,e,dxm1,dxtm1)
call local_grad3(wr,ws,wt,w,N,e,dxm1,dxtm1)
do i=1,nxyz
j = jacmi(i,e)
sij(i,1,e) = j* ! du/dx + du/dx
$ 2*(ur(i)*rxm1(i,1,1,e)+us(i)*sxm1(i,1,1,e)+ut(i)*txm1(i,1,1,e))
sij(i,2,e) = j* ! dv/dy + dv/dy
$ 2*(vr(i)*rym1(i,1,1,e)+vs(i)*sym1(i,1,1,e)+vt(i)*tym1(i,1,1,e))
sij(i,3,e) = j* ! dw/dz + dw/dz
$ 2*(wr(i)*rzm1(i,1,1,e)+ws(i)*szm1(i,1,1,e)+wt(i)*tzm1(i,1,1,e))
sij(i,4,e) = j* ! du/dy + dv/dx
$ (ur(i)*rym1(i,1,1,e)+us(i)*sym1(i,1,1,e)+ut(i)*tym1(i,1,1,e) +
$ vr(i)*rxm1(i,1,1,e)+vs(i)*sxm1(i,1,1,e)+vt(i)*txm1(i,1,1,e) )
sij(i,5,e) = j* ! dv/dz + dw/dy
$ (wr(i)*rym1(i,1,1,e)+ws(i)*sym1(i,1,1,e)+wt(i)*tym1(i,1,1,e) +
$ vr(i)*rzm1(i,1,1,e)+vs(i)*szm1(i,1,1,e)+vt(i)*tzm1(i,1,1,e) )
sij(i,6,e) = j* ! du/dz + dw/dx
$ (ur(i)*rzm1(i,1,1,e)+us(i)*szm1(i,1,1,e)+ut(i)*tzm1(i,1,1,e) +
$ wr(i)*rxm1(i,1,1,e)+ws(i)*sxm1(i,1,1,e)+wt(i)*txm1(i,1,1,e) )
enddo
enddo
elseif (ifaxis) then ! AXISYMMETRIC CASE
c
c Notation: ( 2 x Acheson, p. 353)
c Cylindrical
c Nek5k Coordinates
c
c x z
c y r
c z theta
c
do e=1,nelv
call setaxdy ( ifrzer(e) ) ! change dytm1 if on-axis
call local_grad2(ur,us,u,N,e,dxm1,dytm1)
call local_grad2(vr,vs,v,N,e,dxm1,dytm1)
call local_grad2(wr,ws,w,N,e,dxm1,dytm1)
do i=1,nxyz
j = jacmi(i,e)
r = ym1(i,1,1,e) ! Cyl. Coord:
sij(i,1,e) = j* ! du/dx + du/dx ! e_zz
$ 2*(ur(i)*rxm1(i,1,1,e)+us(i)*sxm1(i,1,1,e))
sij(i,2,e) = j* ! dv/dy + dv/dy ! e_rr
$ 2*(vr(i)*rym1(i,1,1,e)+vs(i)*sym1(i,1,1,e))
if (r.gt.0) then ! e_@@
sij(i,3,e) = v(i,e)/r ! v / r
else
sij(i,3,e) = j* ! L'Hopital's rule: e_@@ = dv/dr
$ 2*(vr(i)*rym1(i,1,1,e)+vs(i)*sym1(i,1,1,e))
endif
sij(i,4,e) = j* ! du/dy + dv/dx ! e_zr
$ ( ur(i)*rym1(i,1,1,e)+us(i)*sym1(i,1,1,e) +
$ vr(i)*rxm1(i,1,1,e)+vs(i)*sxm1(i,1,1,e) )
if (yyyr.gt.0) then ! e_r@
sij(i,5,e) = j* ! dw/dy
$ ( wr(i)*rym1(i,1,1,e)+ws(i)*sym1(i,1,1,e) )
$ - w(i,e) / r
else
sij(i,5,e) = 0
endif
sij(i,6,e) = j* ! dw/dx ! e_ at z
$ ( wr(i)*rxm1(i,1,1,e)+ws(i)*sxm1(i,1,1,e) )
enddo
enddo
else ! 2D CASE
do e=1,nelv
call local_grad2(ur,us,u,N,e,dxm1,dxtm1)
call local_grad2(vr,vs,v,N,e,dxm1,dxtm1)
do i=1,nxyz
j = jacmi(i,e)
sij(i,1,e) = j* ! du/dx + du/dx
$ 2*(ur(i)*rxm1(i,1,1,e)+us(i)*sxm1(i,1,1,e))
sij(i,2,e) = j* ! dv/dy + dv/dy
$ 2*(vr(i)*rym1(i,1,1,e)+vs(i)*sym1(i,1,1,e))
sij(i,3,e) = j* ! du/dy + dv/dx
$ (ur(i)*rym1(i,1,1,e)+us(i)*sym1(i,1,1,e) +
$ vr(i)*rxm1(i,1,1,e)+vs(i)*sxm1(i,1,1,e) )
enddo
enddo
endif
return
end
c-----------------------------------------------------------------------
subroutine y_slice (ua,u,w1,w2)
c
c Extract a y slice of quantity u() - assumes global tens.prod.
c
include 'SIZE'
include 'GEOM'
include 'PARALLEL'
include 'WZ'
include 'ZPER'
c
real ua(nx1,nz1,nelx,nelz),u (nx1,ny1,nz1,nelv)
$ ,w1(nx1,nz1,nelx,nelz),w2(nx1,nz1,nelx,nelz)
integer e,eg,ex,ey,ez
real dy2
c
mxz = nelx*nelz*nx1*nz1
call rzero(ua,mxz)
c
do e=1,nelt
c
eg = lglel(e)
call get_exyz(ex,ey,ez,eg,nelx,nely,nelz)
j = 1
if (ey.eq.1) then
do k=1,nz1
do i=1,nx1
ua(i,k,ex,ez) = u(i,j,k,e)
enddo
enddo
endif
enddo
call gop(ua,w2,'+ ',mxz)
return
end
c-----------------------------------------------------------------------
subroutine z_slice (ua,u,w1,w2)
c
c Extract a z slice of quantity u() - assumes global tens.prod.
c
include 'SIZE'
include 'GEOM'
include 'PARALLEL'
include 'WZ'
include 'ZPER'
c
real ua(nx1,ny1,nelx,nely),u (nx1,ny1,nz1,nelv)
$ ,w1(nx1,ny1,nelx,nely),w2(nx1,ny1,nelx,nely)
integer e,eg,ex,ey,ez
real dy2
c
mxy = nelx*nely*nx1*ny1
call rzero(ua,mxy)
c
do e=1,nelt
c
eg = lglel(e)
call get_exyz(ex,ey,ez,eg,nelx,nely,nelz)
k = 1
if (ez.eq.1) then
do j=1,ny1
do i=1,nx1
ua(i,j,ex,ey) = u(i,j,k,e)
enddo
enddo
endif
enddo
call gop(ua,w2,'+ ',mxy)
return
end
c-----------------------------------------------------------------------
subroutine y_average(ua,u,w1,w2)
c
c Compute the y average of quantity u() - assumes global tens.prod.
c
include 'SIZE'
include 'GEOM'
include 'PARALLEL'
include 'WZ'
include 'ZPER'
c
real ua(nx1,nz1,nelx,nelz),u (nx1,ny1,nz1,nelv)
$ ,w1(nx1,nz1,nelx,nelz),w2(nx1,nz1,nelx,nelz)
integer e,eg,ex,ey,ez
real dy2
c
mxz = nelx*nelz*nx1*nz1
call rzero(ua,mxz)
call rzero(w1,mxz)
c
do e=1,nelt
c
eg = lglel(e)
call get_exyz(ex,ey,ez,eg,nelx,nely,nelz)
c
do k=1,nz1
do i=1,nx1
c dy2 = .5*( ym1(i,ny1,k,e) - ym1(i,1,k,e) )
dy2 = 1.0 ! Assuming uniform in "y" direction
do j=1,ny1
ua(i,k,ex,ez) = ua(i,k,ex,ez)+dy2*wym1(j)*u(i,j,k,e)
w1(i,k,ex,ez) = w1(i,k,ex,ez)+dy2*wym1(j) ! redundant but clear
enddo
enddo
enddo
enddo
c
call gop(ua,w2,'+ ',mxz)
call gop(w1,w2,'+ ',mxz)
c
do i=1,mxz
ua(i,1,1,1) = ua(i,1,1,1) / w1(i,1,1,1) ! Normalize
enddo
c
return
end
c-----------------------------------------------------------------------
subroutine z_average(ua,u,w1,w2)
c
c Compute the z average of quantity u() - assumes global tens.prod.
c
include 'SIZE'
include 'GEOM'
include 'PARALLEL'
include 'WZ'
include 'ZPER'
c
real ua(nx1,ny1,nelx,nely),u (nx1,ny1,nz1,nelv)
$ ,w1(nx1,ny1,nelx,nely),w2(nx1,ny1,nelx,nely)
integer e,eg,ex,ey,ez
real dy2
c
mxy = nelx*nely*nx1*ny1
call rzero(ua,mxy)
call rzero(w1,mxy)
c
do e=1,nelt
c
eg = lglel(e)
call get_exyz(ex,ey,ez,eg,nelx,nely,nelz)
c
do j=1,ny1
do i=1,nx1
dz2 = 1.0 ! Assuming uniform in "z" direction
do k=1,nz1
ua(i,j,ex,ey) = ua(i,j,ex,ey)+dz2*wzm1(k)*u(i,j,k,e)
w1(i,j,ex,ey) = w1(i,j,ex,ey)+dz2*wzm1(k) ! redundant but clear
enddo
enddo
enddo
enddo
c
call gop(ua,w2,'+ ',mxy)
call gop(w1,w2,'+ ',mxy)
c
do i=1,mxy
ua(i,1,1,1) = ua(i,1,1,1) / w1(i,1,1,1) ! Normalize
enddo
c
return
end
c-----------------------------------------------------------------------
subroutine y_avg_buff(ux,uy,uz,c2,name,icount)
c
c Compute the y average of quantity u() - assumes global tens.prod.
c
include 'SIZE'
include 'TOTAL'
include 'ZPER'
c
real ux(1),uy(1),uz(1)
character*2 c2,name
c
parameter (lyavg = lx1*lz1*lelx*lelz)
common /scravg/ u (lyavg)
$ , v (lyavg)
$ , w (lyavg)
$ , w1(lyavg)
$ , w2(lyavg)
c
call y_average(u,ux,w1,w2)
call y_average(v,uy,w1,w2)
call y_average(w,uz,w1,w2)
c
call buff_2d_out(u,v,w,nx1,nz1,nelx,nelz,c2,name,icount)
c
return
end
c-----------------------------------------------------------------------
subroutine z_avg_buff(ux,uy,uz,c2,name,icount)
c
c Compute the z average of quantity u() - assumes global tens.prod.
c
include 'SIZE'
include 'TOTAL'
include 'ZPER'
c
real ux(1),uy(1),uz(1)
character*2 c2,name
c
parameter (lyavg = lx1*ly1*lelx*lely)
common /scravg/ u (lyavg)
$ , v (lyavg)
$ , w (lyavg)
$ , w1(lyavg)
$ , w2(lyavg)
c
call z_average(u,ux,w1,w2)
call z_average(v,uy,w1,w2)
call z_average(w,uz,w1,w2)
call buff_2d_out(u,v,w,nx1,ny1,nelx,nely,c2,name,icount)
return
end
c-----------------------------------------------------------------------
subroutine y_ins_buff(ux,uy,uz,c2,name,icount)
c
c Compute the z average of quantity u() - assumes global tens.prod.
c
include 'SIZE'
include 'TOTAL'
include 'ZPER'
c
real ux(1),uy(1),uz(1)
character*2 c2,name
c
parameter (lyavg = lx1*lz1*lelx*lelz)
common /scravg/ u (lyavg)
$ , v (lyavg)
$ , w (lyavg)
$ , w1(lyavg)
$ , w2(lyavg)
c
call y_slice (u,ux,w1,w2)
call y_slice (v,uy,w1,w2)
call y_slice (w,uz,w1,w2)
c
call buff_2d_out(u,v,w,nx1,nz1,nelx,nelz,c2,name,icount)
c
return
end
c-----------------------------------------------------------------------
subroutine z_ins_buff(ux,uy,uz,c2,name,icount)
c
c Compute the z average of quantity u() - assumes global tens.prod.
c
include 'SIZE'
include 'TOTAL'
include 'ZPER'
c
real ux(1),uy(1),uz(1)
character*2 c2,name
c
parameter (lyavg = lx1*ly1*lelx*lely)
common /scravg/ u (lyavg)
$ , v (lyavg)
$ , w (lyavg)
$ , w1(lyavg)
$ , w2(lyavg)
c
call z_slice (u,ux,w1,w2)
call z_slice (v,uy,w1,w2)
call z_slice (w,uz,w1,w2)
c
call buff_2d_out(u,v,w,nx1,ny1,nelx,nely,c2,name,icount)
c
return
end
c-----------------------------------------------------------------------
subroutine buff_2d_out(u,v,w,nx,ny,nex,ney,c2,name,ifld)
c
include 'SIZE'
include 'TOTAL'
real u(1),v(1),w(1)
character*2 c2,name
character*4 bname
save bname
parameter (lyzm = lelx*max(lely,lelz))
common /scrav2/ ub(lx1,lz1,lyzm),vb(lx1,lz1,lyzm),wb(lx1,lz1,lyzm)
integer ibfld,icalld,nxf,nyf,nexf,neyf
save ibfld,icalld,nxf,nyf,nexf,neyf
data ibfld,icalld,nxf,nyf,nexf,neyf / 6*0 /
c npido = 64 ! 64 files buffered
npido = 128 ! 64 files buffered
npido = min(npido,np) ! P files buffered
mpido = np/npido ! stride between processors (e.g., 128/64 = 2)
jcalld = mod(icalld,npido) ! call # 0,1,...,63,0,1,...
if (mod(nid,mpido) .eq. 0) then ! this is a buffering/writing proc
jid = nid/mpido
if (jid.eq.jcalld) then ! save this buffer on this proc
c write(6,1) nid,jid,istep,icalld,jcalld,c2,name,nex,ney,ifld
c 1 format(5i7,' buffering: ',2a2,3i7)
write(bname,4) c2,name
4 format(2a2)
n = nx*ny*nex*ney
ibfld = ifld
call copy(ub,u,n)
call copy(vb,v,n)
call copy(wb,w,n)
nxf = nx
nyf = ny
nexf = nex
neyf = ney
endif
if (jcalld .eq. npido-1) call ! output buffer
$ outfld2d_p(ub,vb,wb,nxf,nyf,nexf,neyf,bname,ibfld,jid,npido)
endif
icalld = icalld+1
return
end
c-----------------------------------------------------------------------
subroutine y2d(u,v,w,p,c1,icount)
c
c Compute the y average of quantity u() - assumes global tens.prod.
c
include 'SIZE'
include 'TOTAL'
real u(1),v(1),w(1),p(1)
character*1 c1,c2(2)
common /scrns/ ur(lx1*ly1*lz1*lelv)
$ , ut(lx1*ly1*lz1*lelv)
$ , wr(lx1*ly1*lz1*lelv)
$ , wt(lx1*ly1*lz1*lelv)
$ , wp(lx1*ly1*lz1*lelv)
c
c Convert velocities to poloidal-toroidal
c
n = nx1*ny1*nz1*nelv
do i=1,n
rr = xm1(i,1,1,1)*xm1(i,1,1,1)+ym1(i,1,1,1)*ym1(i,1,1,1)
rr = sqrt(rr)
ct = xm1(i,1,1,1)/rr
st = ym1(i,1,1,1)/rr
ur(i) = ct*u(i)+st*v(i)
ut(i) = ct*v(i)-st*u(i)
wr(i) = ur(i)**2
wt(i) = ut(i)**2
wp(i) = w (i)**2
enddo
c2(1) = c1
c2(2) = 'y'
call y_avg_buff(ur,w ,ut,c2,'ub',icount)
call y_avg_buff(wr,wp,wt,c2,'u2',icount)
do i=1,n
wr(i) = ur(i)*ut(i)
wt(i) = ut(i)*w (i)
wp(i) = w (i)*ur(i)
enddo
call y_avg_buff(wr,wt,wp,c2,'uv',icount)
call y_ins_buff(ur,w ,ut,c2,'ui',icount)
return
end
c-----------------------------------------------------------------------
subroutine z2d(u,v,w,p,c1,icount)
c
c Compute the y average of quantity u() - assumes global tens.prod.
c
include 'SIZE'
include 'TOTAL'
real u(1),v(1),w(1),p(1)
character*1 c1,c2(2)
common /scrns/ ur(lx1*ly1*lz1*lelv)
$ , ut(lx1*ly1*lz1*lelv)
$ , wr(lx1*ly1*lz1*lelv)
$ , wt(lx1*ly1*lz1*lelv)
$ , wp(lx1*ly1*lz1*lelv)
c
c
c Convert velocities to poloidal-toroidal
c
n = nx1*ny1*nz1*nelv
do i=1,n
wr(i) = u (i)**2
wt(i) = v (i)**2
wp(i) = w (i)**2
enddo
c2(1) = c1
c2(2) = 'z'
call z_avg_buff(u ,v ,w ,c2,'ub',icount)
call z_avg_buff(wr,wt,wp,c2,'u2',icount)
do i=1,n
wr(i) = u(i)*v(i)
wt(i) = v(i)*w(i)
wp(i) = w(i)*u(i)
enddo
call z_avg_buff(wr,wt,wp,c2,'uv',icount)
call z_ins_buff(u ,v ,w ,c2,'ui',icount)
return
end
c-----------------------------------------------------------------------
subroutine anal_2d
include 'SIZE'
include 'TOTAL'
include 'ZPER'
integer icount
save icount
if (nelx.gt.lelx .or.
$ nely.gt.lely .or.
$ nelz.gt.lelz ) then
if (nid.eq.0) write(6,1) nelx,nely,nelz,lelx,lely,lelz
1 format('anal_2d fail:',6i6)
return
endif
if (istep.eq.0) then ! dump four times, just to keep phase
icount = 0
call z2d(xm1,ym1,zm1,pr,'u',icount)
if (ifmhd) call z2d(xm1,ym1,zm1,pm,'b',icount)
call y2d(xm1,ym1,zm1,pr,'u',icount)
if (ifmhd) call y2d(xm1,ym1,zm1,pm,'b',icount)
endif
icount = icount + 1
call z2d(vx,vy,vz,pr,'u',icount)
if (ifmhd) call z2d(bx,by,bz,pm,'b',icount)
call y2d(vx,vy,vz,pr,'u',icount)
if (ifmhd) call y2d(bx,by,bz,pm,'b',icount)
return
end
c-----------------------------------------------------------------------
subroutine chkit(u,name4,n)
include 'SIZE'
include 'TOTAL'
character*4 name4
real u(1)
integer icalld
save icalld
data icalld /0/
icalld = icalld + 1
u2 = vlsc2(u,u,n)
umin = vlmin(u,n)
umax = vlmax(u,n)
ulst = u(n)
if (nid.eq.0)
$write(6,1) nid,icalld,istep,n,umin,umax,ulst,name4,' chkit',nid
1 format(4i7,1p3e12.4,a4,a6,i1)
return
end
c-----------------------------------------------------------------------
subroutine outmesh
include 'SIZE'
include 'TOTAL'
integer e,eg
common /cmesh/ xt(2**ldim,ldim)
len = wdsize*ndim*(2**ndim)
if (nid.eq.0) open(unit=29,file='rea.new')
do eg=1,nelgt
mtype = eg
call gsync() ! belt
jnid = gllnid(eg)
e = gllel (eg)
if (jnid.eq.0 .and. nid.eq.0) then
call get_el(xt,xm1(1,1,1,e),ym1(1,1,1,e),zm1(1,1,1,e))
call out_el(xt,eg)
elseif (nid.eq.0) then
call crecv(mtype,xt,len)
call out_el(xt,eg)
elseif (jnid.eq.nid) then
call get_el(xt,xm1(1,1,1,e),ym1(1,1,1,e),zm1(1,1,1,e))
call csend(mtype,xt,len,0,0)
endif
call gsync() ! suspenders
enddo
if (nid.eq.0) close(29)
call gsync()
call exitt
return
end
c-----------------------------------------------------------------------
subroutine out_el(xt,e)
include 'SIZE'
include 'TOTAL'
real xt(2**ldim,ldim)
integer e
integer ed(8)
save ed
data ed / 1,2,4,3 , 5,6,8,7 /
write(29,1) e
write(29,2) ((xt(ed(k),j),k=1,4),j=1,ndim)
write(29,2) ((xt(ed(k),j),k=5,8),j=1,ndim)
1 format(12x,'ELEMENT',i6,' [ 1 ] GROUP 0')
2 format(1p4e18.10)
return
end
c-----------------------------------------------------------------------
subroutine get_el(xt,x,y,z)
include 'SIZE'
include 'TOTAL'
real xt(2**ldim,ldim)
real x(nx1,ny1,nz1),y(nx1,ny1,nz1),z(nx1,ny1,nz1)
l = 0
do k=1,nz1,nz1-1
do j=1,ny1,ny1-1
do i=1,nx1,nx1-1
l = l+1
xt(l,1) = x(i,j,k)
xt(l,2) = y(i,j,k)
xt(l,3) = z(i,j,k)
enddo
enddo
enddo
return
end
c-----------------------------------------------------------------------
subroutine shear_calc_max(strsmx,scale,x0,ifdout,iftout)
c
c Compute maximum shear stress on objects
c
c Scale is a user-supplied multiplier so that results may be
c scaled to any convenient non-dimensionalization.
c
c
INCLUDE 'SIZE'
INCLUDE 'TOTAL'
real strsmx(maxobj),x0(3),w1(0:maxobj)
logical ifdout,iftout
common /cvflow_r/ flow_rate,base_flow,domain_length,xsec
$ , scale_vf(3)
common /scrns/ sij (lx1*ly1*lz1*6*lelv)
common /scrcg/ pm1 (lx1,ly1,lz1,lelv)
common /scrsf/ xm0(lx1,ly1,lz1,lelt)
$, ym0(lx1,ly1,lz1,lelt)
$, zm0(lx1,ly1,lz1,lelt)
parameter (lr=lx1*ly1*lz1)
common /scruz/ ur(lr),us(lr),ut(lr)
$ , vr(lr),vs(lr),vt(lr)
$ , wr(lr),ws(lr),wt(lr)
n = nx1*ny1*nz1*nelv
call mappr(pm1,pr,xm0,ym0) ! map pressure onto Mesh 1
c Add mean_pressure_gradient.X to p:
if (param(55).ne.0) then
dpdx_mean = -scale_vf(1)
dpdy_mean = -scale_vf(2)
dpdz_mean = -scale_vf(3)
endif
call add2s2(pm1,xm1,dpdx_mean,n) ! Doesn't work if object is cut by
call add2s2(pm1,ym1,dpdy_mean,n) ! periodicboundary. In this case,
call add2s2(pm1,zm1,dpdz_mean,n) ! set ._mean=0 and compensate in
c
c Compute sij
c
nij = 3
if (if3d.or.ifaxis) nij=6
call comp_sij(sij,nij,vx,vy,vz,ur,us,ut,vr,vs,vt,wr,ws,wt)
c
c
c Fill up viscous array w/ default
c
if (istep.lt.1) call cfill(vdiff,param(2),n)
c
call cadd2(xm0,xm1,-x0(1),n)
call cadd2(ym0,ym1,-x0(2),n)
call cadd2(zm0,zm1,-x0(3),n)
c
x1min=glmin(xm0(1,1,1,1),n)
x2min=glmin(ym0(1,1,1,1),n)
x3min=glmin(zm0(1,1,1,1),n)
c
x1max=glmax(xm0(1,1,1,1),n)
x2max=glmax(ym0(1,1,1,1),n)
x3max=glmax(zm0(1,1,1,1),n)
c
call rzero(strsmx,maxobj)
c
c
nobj = 0
do ii=1,nhis
if (hcode(10,ii).EQ.'I') then
iobj = lochis(1,ii)
memtot = nmember(iobj)
nobj = max(iobj,nobj)
c
if (hcode(1,ii).ne.' ' .or. hcode(2,ii).ne.' ' .or.
$ hcode(3,ii).ne.' ' ) then
ifield = 1
c
c Compute max stress for this object
c
strsmx(ii) = 0.
do mem=1,memtot
ieg = object(iobj,mem,1)
ifc = object(iobj,mem,2)
if (gllnid(ieg).eq.nid) then ! this processor has a contribution
ie = gllel(ieg)
call get_strsmax
$ (strsmxl,xm0,ym0,zm0,sij,pm1,vdiff,ifc,ie)
call cmult(strsmxl,scale,1)
strsmx(ii)=max(strsmx(ii),strsmxl)
endif
enddo
endif
endif
enddo
c
c Max contributions over all processors
c
call gop(strsmx,w1,'M ',maxobj)
return
end
c-----------------------------------------------------------------------
subroutine get_strsmax(strsmax,xm0,ym0,zm0,sij,pm1,visc,f,e)
c
INCLUDE 'SIZE'
INCLUDE 'GEOM'
INCLUDE 'INPUT'
INCLUDE 'TOPOL'
INCLUDE 'TSTEP'
c
real dgtq(3,4)
real xm0 (lx1,ly1,lz1,lelt)
real ym0 (lx1,ly1,lz1,lelt)
real zm0 (lx1,ly1,lz1,lelt)
real sij (lx1,ly1,lz1,3*ldim-3,lelv)
real pm1 (lx1,ly1,lz1,lelv)
real visc(lx1,ly1,lz1,lelv)
integer f,e,pf
real n1,n2,n3
call dsset(nx1,ny1,nz1) ! set up counters
pf = eface1(f) ! convert from preproc. notation
js1 = skpdat(1,pf)
jf1 = skpdat(2,pf)
jskip1 = skpdat(3,pf)
js2 = skpdat(4,pf)
jf2 = skpdat(5,pf)
jskip2 = skpdat(6,pf)
if (if3d.or.ifaxis) then
i = 0
strsmax = 0
do j2=js2,jf2,jskip2
do j1=js1,jf1,jskip1
i = i+1
n1 = unx(i,1,f,e)
n2 = uny(i,1,f,e)
n3 = unz(i,1,f,e)
c
v = visc(j1,j2,1,e)
c
s11 = sij(j1,j2,1,1,e)
s21 = sij(j1,j2,1,4,e)
s31 = sij(j1,j2,1,6,e)
c
s12 = sij(j1,j2,1,4,e)
s22 = sij(j1,j2,1,2,e)
s32 = sij(j1,j2,1,5,e)
s13 = sij(j1,j2,1,6,e)
s23 = sij(j1,j2,1,5,e)
s33 = sij(j1,j2,1,3,e)
stress1 = -v*(s11*n1 + s12*n2 + s13*n3) ! viscous drag
stress2 = -v*(s21*n1 + s22*n2 + s23*n3)
stress3 = -v*(s31*n1 + s32*n2 + s33*n3)
strsnrm = stress1*stress1+stress2*stress2+stress3*stress3
strsmax = max(strsmax,strsnrm)
enddo
enddo
else ! 2D
i = 0
strsmax = 0
do j2=js2,jf2,jskip2
do j1=js1,jf1,jskip1
i = i+1
n1 = unx(i,1,f,e)*area(i,1,f,e)
n2 = uny(i,1,f,e)*area(i,1,f,e)
a = a + area(i,1,f,e)
v = visc(j1,j2,1,e)
s11 = sij(j1,j2,1,1,e)
s12 = sij(j1,j2,1,3,e)
s21 = sij(j1,j2,1,3,e)
s22 = sij(j1,j2,1,2,e)
stress1 = -v*(s11*n1 + s12*n2) ! viscous drag
stress2 = -v*(s21*n1 + s22*n2)
strsnrm = stress1*stress1+stress2*stress2
strsmax = max(strsmax,strsnrm)
enddo
enddo
endif
if (strsmax.gt.0) strsmax = sqrt(strsmax)
return
end
c-----------------------------------------------------------------------
subroutine fix_geom ! fix up geometry irregularities
include 'SIZE'
include 'TOTAL'
parameter (lt = lx1*ly1*lz1)
common /scrns/ xb(lt,lelt),yb(lt,lelt),zb(lt,lelt)
common /scruz/ tmsk(lt,lelt),tmlt(lt,lelt),w1(lt),w2(lt)
integer e,f
character*3 cb
n = nx1*ny1*nz1*nelt
nxyz = nx1*ny1*nz1
nfaces = 2*ndim
ifield = 1 ! velocity field
if (ifheat) ifield = 2 ! temperature field
call rone (tmlt,n)
call dssum (tmlt,nx1,ny1,nz1) ! denominator
call rone (tmsk,n)
do e=1,nelfld(ifield) ! fill mask where bc is periodic
do f=1,nfaces ! so we don't translate periodic bcs (z only)
cb =cbc(f,e,ifield)
if (cb.eq.'P ') call facev (tmsk,e,f,0.0,nx1,ny1,nz1)
enddo
enddo
do kpass = 1,ndim+1 ! This doesn't work for 2D, yet.
! Extra pass is just to test convergence
c call opcopy (xb,yb,zb,xm1,ym1,zm1)
c call opdssum(xb,yb,zb)
call copy (xb,xm1,n)
call copy (yb,ym1,n)
call copy (zb,zm1,n)
call dssum (xb,nx1,ny1,nz1)
call dssum (yb,nx1,ny1,nz1)
call dssum (zb,nx1,ny1,nz1)
xm = 0.
ym = 0.
zm = 0.
do e=1,nelfld(ifield)
do i=1,nxyz ! compute averages of geometry
s = 1./tmlt(i,e)
xb(i,e) = s*xb(i,e)
yb(i,e) = s*yb(i,e)
zb(i,e) = s*zb(i,e)
xb(i,e) = xb(i,e) - xm1(i,1,1,e) ! local displacements
yb(i,e) = yb(i,e) - ym1(i,1,1,e)
zb(i,e) = zb(i,e) - zm1(i,1,1,e)
zb(i,e) = zb(i,e)*tmsk(i,e)
xm = max(xm,abs(xb(i,e)))
ym = max(ym,abs(yb(i,e)))
zm = max(zm,abs(zb(i,e)))
enddo
if (kpass.le.ndim) then
call gh_face_extend(xb(1,e),zgm1,nx1,kpass,w1,w2)
call gh_face_extend(yb(1,e),zgm1,nx1,kpass,w1,w2)
call gh_face_extend(zb(1,e),zgm1,nx1,kpass,w1,w2)
endif
enddo
if (kpass.le.ndim) then
call add2(xm1,xb,n)
call add2(ym1,yb,n)
call add2(zm1,zb,n)
endif
xx = glamax(xb,n)
yx = glamax(yb,n)
zx = glamax(zb,n)
xm = glmax(xm,1)
ym = glmax(ym,1)
zm = glmax(zm,1)
if (nid.eq.0) write(6,1) xm,ym,zm,xx,yx,zx,kpass
1 format(1p6e12.4,' xyz repair',i2)
enddo
param(59) = 1. ! ifdef = .true.
call geom_reset(1) ! reset metrics, etc.
return
end
c-----------------------------------------------------------------------
subroutine gh_face_extend(x,zg,n,gh_type,e,v)
include 'SIZE'
real x(1),zg(1),e(1),v(1)
integer gh_type
if (ndim.eq.2) then
call gh_face_extend_2d(x,zg,n,gh_type,e,v)
else
call gh_face_extend_3d(x,zg,n,gh_type,e,v)
endif
return
end
c-----------------------------------------------------------------------
subroutine gh_face_extend_2d(x,zg,n,gh_type,e,v)
c
c Extend 2D faces into interior via gordon hall
c
c gh_type: 1 - vertex only
c 2 - vertex and faces
c
c
real x(n,n)
real zg(n)
real e(n,n)
real v(n,n)
integer gh_type
c
c Build vertex interpolant
c
ntot=n*n
call rzero(v,ntot)
do jj=1,n,n-1
do ii=1,n,n-1
do j=1,n
do i=1,n
si = 0.5*((n-ii)*(1-zg(i))+(ii-1)*(1+zg(i)))/(n-1)
sj = 0.5*((n-jj)*(1-zg(j))+(jj-1)*(1+zg(j)))/(n-1)
v(i,j) = v(i,j) + si*sj*x(ii,jj)
enddo
enddo
enddo
enddo
if (gh_type.eq.1) then
call copy(x,v,ntot)
return
endif
c Extend 4 edges
call rzero(e,ntot)
c
c x-edges
c
do jj=1,n,n-1
do j=1,n
do i=1,n
hj = 0.5*((n-jj)*(1-zg(j))+(jj-1)*(1+zg(j)))/(n-1)
e(i,j) = e(i,j) + hj*(x(i,jj)-v(i,jj))
enddo
enddo
enddo
c
c y-edges
c
do ii=1,n,n-1
do j=1,n
do i=1,n
hi = 0.5*((n-ii)*(1-zg(i))+(ii-1)*(1+zg(i)))/(n-1)
e(i,j) = e(i,j) + hi*(x(ii,j)-v(ii,j))
enddo
enddo
enddo
call add3(x,e,v,ntot)
return
end
c-----------------------------------------------------------------------
subroutine gh_face_extend_3d(x,zg,n,gh_type,e,v)
c
c Extend faces into interior via gordon hall
c
c gh_type: 1 - vertex only
c 2 - vertex and edges
c 3 - vertex, edges, and faces
c
c
real x(n,n,n)
real zg(n)
real e(n,n,n)
real v(n,n,n)
integer gh_type
c
c Build vertex interpolant
c
ntot=n*n*n
call rzero(v,ntot)
do kk=1,n,n-1
do jj=1,n,n-1
do ii=1,n,n-1
do k=1,n
do j=1,n
do i=1,n
si = 0.5*((n-ii)*(1-zg(i))+(ii-1)*(1+zg(i)))/(n-1)
sj = 0.5*((n-jj)*(1-zg(j))+(jj-1)*(1+zg(j)))/(n-1)
sk = 0.5*((n-kk)*(1-zg(k))+(kk-1)*(1+zg(k)))/(n-1)
v(i,j,k) = v(i,j,k) + si*sj*sk*x(ii,jj,kk)
enddo
enddo
enddo
enddo
enddo
enddo
if (gh_type.eq.1) then
call copy(x,v,ntot)
return
endif
c
c
c Extend 12 edges
call rzero(e,ntot)
c
c x-edges
c
do kk=1,n,n-1
do jj=1,n,n-1
do k=1,n
do j=1,n
do i=1,n
hj = 0.5*((n-jj)*(1-zg(j))+(jj-1)*(1+zg(j)))/(n-1)
hk = 0.5*((n-kk)*(1-zg(k))+(kk-1)*(1+zg(k)))/(n-1)
e(i,j,k) = e(i,j,k) + hj*hk*(x(i,jj,kk)-v(i,jj,kk))
enddo
enddo
enddo
enddo
enddo
c
c y-edges
c
do kk=1,n,n-1
do ii=1,n,n-1
do k=1,n
do j=1,n
do i=1,n
hi = 0.5*((n-ii)*(1-zg(i))+(ii-1)*(1+zg(i)))/(n-1)
hk = 0.5*((n-kk)*(1-zg(k))+(kk-1)*(1+zg(k)))/(n-1)
e(i,j,k) = e(i,j,k) + hi*hk*(x(ii,j,kk)-v(ii,j,kk))
enddo
enddo
enddo
enddo
enddo
c
c z-edges
c
do jj=1,n,n-1
do ii=1,n,n-1
do k=1,n
do j=1,n
do i=1,n
hi = 0.5*((n-ii)*(1-zg(i))+(ii-1)*(1+zg(i)))/(n-1)
hj = 0.5*((n-jj)*(1-zg(j))+(jj-1)*(1+zg(j)))/(n-1)
e(i,j,k) = e(i,j,k) + hi*hj*(x(ii,jj,k)-v(ii,jj,k))
enddo
enddo
enddo
enddo
enddo
c
call add2(e,v,ntot)
c
if (gh_type.eq.2) then
call copy(x,e,ntot)
return
endif
c
c Extend faces
c
call rzero(v,ntot)
c
c x-edges
c
do ii=1,n,n-1
do k=1,n
do j=1,n
do i=1,n
hi = 0.5*((n-ii)*(1-zg(i))+(ii-1)*(1+zg(i)))/(n-1)
v(i,j,k) = v(i,j,k) + hi*(x(ii,j,k)-e(ii,j,k))
enddo
enddo
enddo
enddo
c
c y-edges
c
do jj=1,n,n-1
do k=1,n
do j=1,n
do i=1,n
hj = 0.5*((n-jj)*(1-zg(j))+(jj-1)*(1+zg(j)))/(n-1)
v(i,j,k) = v(i,j,k) + hj*(x(i,jj,k)-e(i,jj,k))
enddo
enddo
enddo
enddo
c
c z-edges
c
do kk=1,n,n-1
do k=1,n
do j=1,n
do i=1,n
hk = 0.5*((n-kk)*(1-zg(k))+(kk-1)*(1+zg(k)))/(n-1)
v(i,j,k) = v(i,j,k) + hk*(x(i,j,kk)-e(i,j,kk))
enddo
enddo
enddo
enddo
c
call add2(v,e,ntot)
call copy(x,v,ntot)
return
end
c-----------------------------------------------------------------------
function ran1(idum)
c
integer idum,ia,im,iq,ir,ntab,ndiv
real ran1,am,eps,rnmx
c
parameter (ia=16807,im=2147483647,am=1./im,iq=127773,ir=2836)
parameter (ntab=32,ndiv=1+(im-1)/ntab,eps=1.2e-7,rnmx=1.-eps)
c
c Numerical Rec. in Fortran, 2nd eD. P. 271
c
integer j,k
integer iv(ntab),iy
save iv,iy
data iv,iy /ntab*0,0/
c
if (idum.le.0.or.iy.eq.0) then
idum=max(-idum,1)
do j=ntab+8,1,-1
k = idum/iq
idum = ia*(idum-k*iq)-ir*k
if(idum.lt.0) idum = idum+im
if (j.le.ntab) iv(j) = idum
enddo
iy = iv(1)
endif
k = idum/iq
idum = ia*(idum-k*iq)-ir*k
if(idum.lt.0) idum = idum+im
j = 1+iy/ndiv
iy = iv(j)
iv(j) = idum
ran1 = min(am*iy,rnmx)
c ran1 = cos(ran1*1.e8)
return
end
c-----------------------------------------------------------------------
subroutine rand_fld_h1(x)
include 'SIZE'
real x(1)
n=nx1*ny1*nz1*nelt
id = n
do i=1,n
x(i) = ran1(id)
enddo
call dsavg(x)
return
end
c-----------------------------------------------------------------------
subroutine rescale_x (x,x0,x1)
include 'SIZE'
real x(1)
n = nx1*ny1*nz1*nelt
xmin = glmin(x,n)
xmax = glmax(x,n)
if (xmax.le.xmin) return
scale = (x1-x0)/(xmax-xmin)
do i=1,n
x(i) = x0 + scale*(x(i)-xmin)
enddo
return
end
c-----------------------------------------------------------------------
More information about the Nek5000-users
mailing list