c c c c ************************************************** c ************************************************** c ************************************************** c ************************************************** c ***** ***** c ***** ***** c ***** dhpio ***** c ***** ***** c ***** ***** c ************************************************** c ************************************************** c ************************************************** c ************************************************** c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c This routine does a dhp io dump c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c subroutine tile_cdump(itx,ity,nz,ny,nx,dz,dy,dx,nbdy,ddd,ncdump) parameter (MX_DATA=5) real ddd( MX_DATA, 1:nz, 1-nbdy:ny+nbdy, 1-nbdy:nx+nbdy ) real xxl(1-nbdy:nx+nbdy+1) real yyl(1-nbdy:ny+nbdy+1) real zzl(1-nbdy:nz+nbdy+1) real dx, dy, dz integer i, nx, ny, nz, nbdy, iunit character*11 namedp common /ionames/ namedp common /tilelayout/ ntilex, ntiley c data namedp/'a00a0000aaa'/ c return c do i=1,nx+1 xxl(i) = dx * float(nx*itx + i-1) enddo do i=1,ny+1 yyl(i) = dy * float(ny*ity + i-1) enddo do i=1,nz+1 zzl(i) = dz * float(i-1) enddo namedp( 5: 5) = char(ichar('0') + ncdump/1000 ) namedp( 6: 6) = char(ichar('0') + mod(ncdump/100 , 10)) namedp( 7: 7) = char(ichar('0') + mod(ncdump/10 , 10)) namedp( 8: 8) = char(ichar('0') + mod(ncdump , 10)) namedp( 9: 9) = char(ichar('a') + itx) namedp(10:10) = char(ichar('a') + ity) namedp(11:11) = 'a' write (6,*) ' Compressed dump:',namedp call binopen(namedp,11,iunit) c call var0d("time\0", "T\0", time,iunit) c call var0d("Time Step\0", "DT\0", dtime,iunit) c call var0d("N Cycle\0", "NCYCLE\0", float(ncycle),iunit) c call var0d("Polytropic Index\0", "GAMA\0", eosgam,iunit) call nprogs(ntilex,ntiley,1,itx,ity,0,iunit) call mesho3('X', 'Y', 'Z', nx, ny, nz, nbdy, xxl, yyl, zzl, iunit) call var3df( "Density\0","RHO\0",nx,ny,nz,nbdy,ddd, 1,0,iunit) call var3df( "Pressure\0","PRS\0",nx,ny,nz,nbdy,ddd, 2,0,iunit) call var3df( "X-Velocity\0", "Ux\0",nx,ny,nz,nbdy,ddd, 3,0,iunit) call var3df( "Y-Velocity\0", "Uy\0",nx,ny,nz,nbdy,ddd, 4,0,iunit) call var3df( "Z-Velocity\0", "Uz\0",nx,ny,nz,nbdy,ddd, 5,0,iunit) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ddd : 1 2 3 4 5 c c rho p ux uy uz c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc call binclose(iunit) c return end C=====================================================================72 c --- CUT HERE ---- C======================================================================C C C C COPYRIGHT WOODWARD RESEARCH GROUP - I/O PACKAGE - 19th July 1990. C C Authors: C C DAVID PORTER C C TOM VARGHESE C C C C======================================================================C c subroutine var1d(name, symb, ngrid, unpacked,packed,iunit) parameter (NBITS = 16) character*20 name, symb character*80 str integer ngrid, packed((ngrid+3)/4) real fmin, fmax, scale, unpacked(ngrid) integer idata(128) character*1024 cdata equivalence (idata(1), cdata) lennam = Index(name,'\0') - 1 lensym = Index(symb,'\0') - 1 i1 = 8 + lennam i2 = i1 + 14 i3 = i2 + lensym i4 = i3 + 2 ioffset = 8*((i4+7)/8) - i4 i4 = i4 + ioffset + 1 i5 = i4 + 79 nw = i5 / 8 nwords = (ngrid + 3) / 4 nbytes = 8 * nwords ngrid4 = ((ngrid +3)/4)*4 call packf2i(unpacked,ngrid4,packed,fmin,fmax,scale) c write (6,*) 'i1,i2,i3,i4,i5,nw,nwords,nbytes,fmax' c write (6,*) i1,i2,i3,i4,i5,nw,nwords,nbytes,fmax write(str,999) fmin, fmax, nbytes 999 format('MINVAL="',e15.8,'" MAXVAL="',e15.8, 1 '" BYTE2BIT15D2="',i10'"') cdata(1: 8) = 'NAME1D="' cdata(9:i1) = name(1:lennam) cdata(i1+1:i2) = '" SYMBOL1D="' cdata(i2+1:i3) = symb(1:lensym) cdata(i3+1:i3+9) = '" ' cdata(i4:i4) = char(10) cdata(i4+1:i5) = str(1:79) c buffer out (4,0) (idata(1), idata(nw)) c buffer out (4,0) (packed(1), packed(nwords)) nw2 = nw * 2 nword2 = nwords * 2 call binwrite(iunit,idata(1),nw2) call binwrite(iunit,packed(1),nword2) return end c=====================================================================72 c Flipped version of var3d : output in z, y, x order c subroutine var3df(name,symb,nx,ny,nz,nbdy,data,iv,ilog,iunit) parameter (NBITS = 16) parameter (nxymax = 128*128) parameter (nxmax = 128) parameter (MX_DATA=5) character*20 name, symb character*80 str integer nx, ny, nz, packed(nxymax) real data( MX_DATA, 1:nz, 1-nbdy:ny+nbdy, 1-nbdy:nx+nbdy ) real minn(nxmax), maxx(nxmax), fmin, fmax, scale, dat(nxymax) integer idata(128) character*1024 cdata equivalence (idata(1), cdata) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c This code requires nx*ny to be a multiple of 4 c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc if(((nx*ny)/4)*4 .ne. nx*ny) then write (6,*) 'var3df: nx*ny = ', nx*ny write (6,*) 'var3df: nx*ny needs to be a multiple of 4' stop endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Find maximum & minimum elements of array data c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc do 10 i=1,nz minn(i) = data(iv,i,1,1) maxx(i) = data(iv,i,1,1) 10 continue do 20 i=1,nz do 20 j=1,ny do 20 k=1,nx minn(i) = amin1(minn(i), data(iv,i,j,k)) maxx(i) = amax1(maxx(i), data(iv,i,j,k)) 20 continue fmin = minn(1) fmax = maxx(1) do 30 i=2,nz fmin = amin1(fmin, minn(i)) fmax = amax1(fmax, maxx(i)) 30 continue if(ilog .eq. 1) fmin = alog(fmin) if(ilog .eq. 1) fmax = alog(fmax) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Write out header for this data block c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc lennam = Index(name,'\0') - 1 lensym = Index(symb,'\0') - 1 i1 = 8 + lennam i2 = i1 + 14 i3 = i2 + lensym i4 = i3 + 2 ioffset = 8*((i4+7)/8) - i4 i4 = i4 + ioffset + 1 i5 = i4 + 79 nw = i5 / 8 nbytes = 2 * nx * ny * nz write(str,999) fmin, fmax, nbytes 999 format('MINVAL="',e15.8,'" MAXVAL="',e15.8, 1 '" BYTE2BIT15D3="',i10'"') cdata(1: 8) = 'NAME3D="' cdata(9:i1) = name(1:lennam) cdata(i1+1:i2) = '" SYMBOL3D="' cdata(i2+1:i3) = symb(1:lensym) cdata(i3+1:i3+9) = '" ' cdata(i4:i4) = char(10) cdata(i4+1:i5) = str(1:79) nw2 = nw * 2 call binwrite(iunit,idata(1),nw2) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Write out data as packed 16-bit integers one plane at a time. c c Note: subroutine PCKF2I does not calculate min and max. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc nxy = nx*ny nwords = nxy / 4 do 550 k=1,nz if(ilog .ne. 1) then do 510 j=1,ny do 510 i=1,nx dat(i+nx*(j-1)) = data(iv,k,j,i) 510 continue else do 520 j=1,ny do 520 i=1,nx dat(i+nx*(j-1)) = alog(data(iv,k,j,i)) 520 continue endif call pckf2i(dat,nxy,packed,fmin,fmax,scale) nword2 = 2 * nwords call binwrite(iunit,packed(1),nword2) 550 continue return end c data C=====================================================================72 c subroutine nprogs(nprogx,nprogy,nprogz,iprogx,iprogy,iprogz,iunit) integer idata(128) character*1024 cdata equivalence (idata(1), cdata) write (cdata( 1:1024),998) nprogx, nprogy, nprogz 998 format('NPROG1="',i5,'" NPROG2="',i5,'" NPROG3="',i5,'"') cdata(51:51) = char(10) write (cdata(52:1024),999) iprogx, iprogy, iprogz 999 format('IPROG1="',i5,'" IPROG2="',i5,'" IPROG3="',i5,'" ') cdata(104:104) = char(10) nw = 13 nw2 = 2 * nw call binwrite(iunit,idata(1),nw2) return end c C======================================================================C C C C COPYRIGHT WOODWARD RESEARCH GROUP - I/O PACKAGE - 19th July 1990. C C Authors: C C DAVID PORTER C C TOM VARGHESE C C C C======================================================================C c subroutine var0d(name, symb, value,iunit) character*20 name, symb, str real value integer idata(128) character*1024 cdata equivalence (idata(1), cdata) lennam = Index(name,'\0') - 1 lensym = Index(symb,'\0') - 1 i1 = 8 + lennam i2 = i1 + 14 i3 = i2 + lensym i4 = i3 + 13 i5 = i4 + 15 nw = 1 + (i5+1)/8 i6 = 8 * nw write(str,999) value 999 format(e15.6) cdata( 1: 8) = 'NAME0D="' cdata( 9:i1) = name(1:lennam) cdata(i1+1:i2) = '" SYMBOL0D="' cdata(i2+1:i3) = symb(1:lensym) cdata(i3+1:i4) = '" VALUE0D="' cdata(i4+1:i5) = str(1:15) cdata(i5+1:i5+9) = '" ' cdata(i6:i6) = char(10) c buffer out (4,0) (idata(1), idata(nw)) nw2 = nw * 2 call binwrite(iunit,idata(1),nw2) return end C C=====================================================================72 C======================================================================C C C C COPYRIGHT WOODWARD RESEARCH GROUP - I/O PACKAGE - 19th July 1990. C C Authors: C C DAVID PORTER C C TOM VARGHESE C C C C======================================================================C C c c -- NOTE: KEEP MAXVECTOR a power of 2 -- subroutine packf2i(unpacked,ngrid,packed,fmin,fmax,scale) c parameter (NBITS = 16) parameter (MAXVECTOR = 1024) integer ngrid, packed(ngrid) integer itmp(MAXVECTOR) real fmin, fmax, scale, unpacked(ngrid) real mintmp(MAXVECTOR), maxtmp(MAXVECTOR) c c -- Define some constants -- small = 1.0e-06 c small = ifelse(ifcray,1,1.0e-06,1.0d-06) c c -- Find minima and maxima of unpacked real array -- c do 90 i = 1, MAXVECTOR mintmp(i) = unpacked(1) maxtmp(i) = unpacked(1) 90 continue c c do 100 i = 1, amin0(MAXVECTOR,ngrid) mintmp(i) = unpacked(i) maxtmp(i) = unpacked(i) 100 continue c c c do 200 j = 2, (ngrid+MAXVECTOR-1)/MAXVECTOR ns = (j-1) * MAXVECTOR do 210 i = 1, amin0(ngrid-ns, MAXVECTOR) mintmp(i) = amin1(mintmp(i), unpacked(ns + i)) maxtmp(i) = amax1(maxtmp(i), unpacked(ns + i)) 210 continue 200 continue c c c ilen = amin0(MAXVECTOR,ngrid) 500 ilen = ( ilen + 1) /2 cdir$ ivdep do 600 i = 1, ilen mintmp(i) = amin1(mintmp(i), mintmp(ilen+i)) maxtmp(i) = amax1(maxtmp(i), maxtmp(ilen+i)) 600 continue maxtmp(ilen+1) = maxtmp(1) mintmp(ilen+1) = mintmp(1) if ( ilen .ge. 8 ) goto 500 c fmin = mintmp(1) fmax = maxtmp(1) c do 700 i = 2, ilen fmin = amin1(fmin, mintmp(i)) fmax = amax1(fmax, maxtmp(i)) 700 continue c c -- minima and maxima - done -- c scale = ((2.0 ** (NBITS-1)) - 1.0) / amax1 (small, (fmax - fmin)) iscl = 2 ** NBITS c do 800 j = 1, (ngrid + MAXVECTOR - 1) / MAXVECTOR ns = (j-1) * MAXVECTOR do 810 i = 1, amin0(ngrid-ns, MAXVECTOR) itmp(i) = (unpacked(ns + i) - fmin) * scale 810 continue ix = ns/(32/NBITS) + 1 iy = amin0(MAXVECTOR,ngrid-ns) do 815 i=0, iy-2, 2 packed(ix+i/2) = iscl * itmp(1+i) + itmp(2+i) 815 continue c call pack( packed(ix), NBITS, itmp,iy) 800 continue c c c return end c C=====================================================================72 C======================================================================C C C C COPYRIGHT WOODWARD RESEARCH GROUP - I/O PACKAGE - 19th July 1990. C C Authors: C C DAVID PORTER C C TOM VARGHESE C C C C======================================================================C c c -- NOTE: KEEP MAXVECTOR a power of 2 -- subroutine pckf2i(unpacked,ngrid,packed,fmin,fmax,scale) c parameter (NBITS = 16) parameter (MAXVECTOR = 1024) integer ngrid, packed(ngrid) integer itmp(MAXVECTOR) real fmin, fmax, scale, unpacked(ngrid) real mintmp(MAXVECTOR), maxtmp(MAXVECTOR) c c -- Define some constants -- small = 1.0e-06 c small = ifelse(ifcray,1,1.0e-06,1.0d-06) c c -- minima and maxima of unpacked real array are calculated elsewhere -- c scale = ((2.0 ** (NBITS-1)) - 1.0) / amax1 (small, (fmax - fmin)) iscl = 2 ** NBITS c do 800 j = 1, (ngrid + MAXVECTOR - 1) / MAXVECTOR ns = (j-1) * MAXVECTOR do 810 i = 1, amin0(ngrid-ns, MAXVECTOR) itmp(i) = (unpacked(ns + i) - fmin) * scale 810 continue ix = ns/(32/NBITS) + 1 iy = amin0(MAXVECTOR,ngrid-ns) do 815 i=0, iy-2, 2 packed(ix+i/2) = iscl * itmp(1+i) + itmp(2+i) 815 continue c call pack( packed(ix), NBITS, itmp,iy) 800 continue c return end c c ----------------------------------------------------------------------------- subroutine setbufdhp(name,length) character*32 name character*80 string c lengg = length + 1 10 lengg = lengg - 1 if(name(lengg:lengg) .eq. ' ') go to 10 length = lengg c open(unit=94, file=".assign") string(1:length) = name(1:length) i = length + 1 j = i + 60 string(i:j) = ^ "::unblocked::::::::: assign -s unblocked f:" i = j + 1 j = i + length-1 string(i:j) = name(1:length) write(94,999)(string(i:i), i = 1,j) close(94) c 999 format(80A1) c return end c ^ "::pure:::::::::::::: assign -s pure f:" CRAY-2 c ^ "::unblocked::::::::: assign -s unblocked f:" YMP c C======================================================================C C C C COPYRIGHT WOODWARD RESEARCH GROUP - I/O PACKAGE - 19th July 1990. C C Authors: C C DAVID PORTER C C TOM VARGHESE C C Hacker: C C GENE BASSETT C C C C======================================================================C c subroutine mesho3(s1,s2,s3,n1,n2,n3,nbound,intrl1,intrl2,intrl3, 1 iunit) character*1 s1, s2, s3 integer n1, n2, n3, nbound real len1, len2, len3 real intrl1(-nbound+1:n1+nbound+1) real intrl2(-nbound+1:n1+nbound+1) real intrl3(-nbound+1:n3+nbound+1) integer idata(128) character*1024 cdata equivalence (idata(1), cdata) write (cdata(1:1024),997) s1, s2, s3 997 format('COORD1="',a1,'" COORD2="',a1,'" COORD3="',a1'"') cdata(39:39) = char(10) write (cdata(40:1024),998) n1, n2, n3 998 format('MESH1="',i5,'" MESH2="',i5,'" MESH3="',i5,'"') cdata(87:87) = char(10) cdata(88:88) = char(10) nw = 11 nw2 = 2 * nw call binwrite(iunit,idata(1),nw2) c c write (cdata(1:1024),996) 1+16*(n3+1) 996 format('INTRL3="',i6,'"') cdata(16:16) = char(10) c buffer out (4,0) (idata(1), idata(2)) call binwrite(iunit,idata(1),4) do 10 j3=1,n3+1 write (cdata(1:1024),995) intrl3(j3) 995 format(1p,e15.7) cdata(16:16) = char(10) c buffer out (4,0) (idata(1), idata(2)) call binwrite(iunit,idata(1),4) 10 continue c write (cdata(1:1024),994) 1+16*(n2+1) 994 format('INTRL2="',i6,'"') cdata(16:16) = char(10) c buffer out (4,0) (idata(1), idata(2)) call binwrite(iunit,idata(1),4) do 20 j2=1,n2+1 write (cdata(1:1024),993) intrl2(j2) 993 format(1p,e15.7) cdata(16:16) = char(10) c buffer out (4,0) (idata(1), idata(2)) call binwrite(iunit,idata(1),4) 20 continue c write (cdata(1:1024),992) 1+16*(n1+1) 992 format('INTRL1="',i6,'"') cdata(16:16) = char(10) c buffer out (4,0) (idata(1), idata(2)) call binwrite(iunit,idata(1),4) do 30 j1=1,n1+1 write (cdata(1:1024),991) intrl1(j1) 991 format(1p,e15.7) cdata(16:16) = char(10) c buffer out (4,0) (idata(1), idata(2)) call binwrite(iunit,idata(1),4) 30 continue c 990 format(' ') c return end c c ************************************************** c ************************************************** c ************************************************** c ************************************************** c ***** ***** c ***** ***** c ***** i n n cc n n a m m ***** c ***** i nn n c c nn n a m m ***** c ***** i n n n c n n n a a mm mm ***** c ***** i n n n c n n n a a mm mm ***** c ***** i n nn c c n nn aaaaa m m m ***** c ***** i n n cc n n a a m m m ***** c ***** ***** c ***** ***** c ************************************************** c ************************************************** c ************************************************** c ************************************************** c c --- incnam increments the last 4 digits in name by +1. c name is type character*8 (right-justified). c c subroutine incnam (name) character*11 name c if(name(8:8) .eq. '9') go to 10 name(8:8) = char(1 + ichar(name(8:8))) return c 10 if(name(7:7) .eq. '9') go to 20 name(7:7) = char(1 + ichar(name(7:7))) name(8:8) = '0' return c 20 if(name(6:6) .eq. '9') go to 30 name(6:6) = char(1 + ichar(name(6:6))) name(7:7) = '0' name(8:8) = '0' return c 30 if(name(5:5) .eq. '9') stop name(5:5) = char(1 + ichar(name(5:5))) name(6:6) = '0' name(7:7) = '0' name(8:8) = '0' c return end