#if defined(IBM) || defined(AIX) #define LNBLNK_OR_LEN_TRIM len_trim #elif defined(T3E) #define LNBLNK_OR_LEN_TRIM trimlen #else #define LNBLNK_OR_LEN_TRIM lnblnk #endif !> hdfdump-para.F !! functions to provide HDF dump files for the magnetospheric runs !! The organization of the files is for the MHD: !! - One dump with the grid info !! - Dumps for each time step !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !> mhd_open_write_hdf !! !! Opens the hdf file and creates the file attributes !! !! Also creates a unique run identifier ( date, time, machine, and cwd ) !! shared with the other dump routines !! !! if the modified julian date (mjd) > 0, mhd_open_write_hdf !! takes the modified julian date as input. !! integer function MHD_OPEN_WRITE_HDF(base,suffix_1, suffix_2, $ mjd, itimestep, time_of_step) implicit none ! ... Variables ........................................................ ! ! Implicit none declarations; required before includes ! integer itimestep,ni_globalp1,nj_globalp1,nk_globalp1,info_out, $ lnbnk,lnblnk,istart,kku,llen,istop,llstep,name_start, $ name_stop integer nsize_i,nsize_j,nsize_k,npad,len integer i,j,k integer hdfdump_close, hdfdump_var integer ion_open_hdf, ion2d_dump_var, mhd_open_hdf, iondump_first character*80 fname,dumpfile #include "hdf.inc" #include "global_dims.inc" #include "help.inc" integer NI,NJ,NK,no,li,lj,lk integer llow, lihigh, ljhigh integer num_procs, num_mhd, num_ion #include "param.inc" #include "run-time.inc" #include "dipole.inc" #include "runattr.inc" #include "boundx.inc" #include "info.inc" ! revision.inc is generated by build process ! should contain the following: ! CHARACTER*(*) REPO_REV ! PARAMETER(REPO_REV=REPOSITORY_VERSION) #include "revision.inc" character*256 revision_str integer blnk_len integer, SAVE :: variable_number c function type declarations integer sfstart, sfend, sfscatt, sfcreate, sfwcdata integer sfwdata, sfendacc, sfsnatt integer sfsattr, sfrattr c real*4, allocatable :: swtable(:,:) integer*4, save :: iFileId integer*4 iSecId, iaDimId, iRank, iStatus integer iLen integer iaDim4d(4), iaStart4d(4), iaEdge4d(4),iaStride4d(4) integer iaDim3d(3), iaStart3d(3), iaEdge3d(3),iaStride3d(3) integer iaDim2d(2), iaStart2d(2), iaEdge2d(2),iaStride2d(2) integer iaDim1d(1), iaStart1d(1), iaEdge1d(1),iaStride1d(1) integer iVal character*1200 varname_list character*80 caCont, caDim, caSec, caAttr character*20 caTmp character*120 output_file real*8 time_of_step, ttime, tttime real*4 time_4byte c declarations for hdfdump_var entry integer, save :: varnum character*40 units character*12 varname real*4, allocatable :: dummy_hdf(:,:,:) logical GRID character*2 LF0 real dumvar dimension dumvar(-npad+1:nsize_i+npad,-npad+1:nsize_j+npad, $ -npad+1:nsize_k+npad) ! ... Parameter Variables .............................................. character*128 base, suffix_1, suffix_2 real*8 mjd !> mjd - modified julian date ! ... Begin ............................................................ #ifdef DEBUG_MODE_ON write(*,*) "DEBUG: in hdfdump-para.F::mhd_open_write_hdf(...)" #endif c c check to see if this is the I/O processor c variable_number = 0 mhd_open_write_hdf = 0 if ( mype .ne. 0 ) return LF0(1:2) = char(12)//char(0) c c !open and setup hdf file c c ilen = index(base, char(0))-1 if (mjd < 0) then write(output_file, 976) base(1:ilen), suffix_1(1:7), $ suffix_2(1:3) else write(output_file, 976) base(1:ilen), suffix_1(1:20), $ suffix_2(1:3) endif 976 format(A, '_mhd_', A, '.', A) ilen = blnk_len(output_file,120) ! write(*,977) output_file(1:ilen) ! 977 format("Writting, '", A, "'") iFileId = sfstart(output_file(1:ilen),DFACC_CREATE) ni_globalp1 = ni_global + 1 nj_globalp1 = nj_global + 1 nk_globalp1 = nk_global + 1 c call rststr(varname_list) c iStatus = info_out(iFileId,'old run name',old_run_name) iStatus = info_out(iFileId,'old run info',old_runinfo) iStatus = info_out(iFileId,'old go namelist',old_go) iStatus = info_out(iFileId,'old rings namelist',old_rings) iStatus = info_out(iFileId,'old swind namelist',old_sw) iStatus = info_out(iFileId,'old const namelist',old_const) iStatus = info_out(iFileId,'old ion namelist',old_ion) iStatus = info_out(iFileId,'new run name',new_run_name) iStatus = info_out(iFileId,'new run info',new_runinfo) iStatus = info_out(iFileId,'new go namelist',new_go) iStatus = info_out(iFileId,'new rings namelist',new_rings) iStatus = info_out(iFileId,'new swind namelist',new_sw) iStatus = info_out(iFileId,'new const namelist',new_const) iStatus = info_out(iFileId,'new ion namelist',new_ion) if (itable .eq. 0 ) then istatus = sfsattr(iFileId,'no_solar_wind',DFNT_CHAR8, $ 12,'no SW-SM-DAT') else allocate(swtable(itable,11)) do i=1,itable swtable(i,1) = UT(i) swtable(i,2) = Njp(i) swtable(i,3) = Vjx(i) swtable(i,4) = Vjy(i) swtable(i,5) = Vjz(i) swtable(i,6) = Cs(i) swtable(i,7) = Bjx(i) swtable(i,8) = Bjy(i) swtable(i,9) = Bjz(i) swtable(i,10) = BjT(i) swtable(i,11) = Zangle(i) enddo c ! In this format each variable is its own SDS iRank=2 iaDim2d(1) = itable iaDim2d(2) = 11 do i=1,2 iaStride2d(i)=1 iaStart2d(i)=0 iaEdge2d(i)= iaDim2d(i) enddo c iSecId=sfcreate(iFileId,'solar_wind_file',DFNT_FLOAT32, $ iRank,iaDim2d) c istatus = sfsattr(iSecId,'UT_offset',DFNT_FLOAT32,1,UT0) istatus = sfsattr(iSecId,'table_length',DFNT_INT32,1,itable) c iStatus = sfwdata(iSecId,iaStart2d,iaStride2d,iaEdge2d,swtable) deallocate(swtable) c endif c ! ! Dump Modified Julian Date if it's greater than 0... ! if (mjd > 0) then #ifdef DEBUG_MODE_ON write(6,*) ' Writing modified julian date' #endif iStatus = sfscatt(iFileId,'mjd',DFNT_FLOAT64,1,mjd) iStatus = sfsnatt(iFileId,'mjd',DFNT_FLOAT64,1,mjd) endif !Dump Time Step #ifdef DEBUG_MODE_ON write(6,*) ' Writing time step' #endif c iStatus = sfscatt(iFileId,'time_step',DFNT_INT32,1,LSTEP) iStatus = sfsnatt(iFileId,'time_step',DFNT_INT32,1,LSTEP) !Dump Time ttime = time_of_step #ifdef DEBUG_MODE_ON write(6,*) ' Writing time' #endif iStatus = sfsnatt(iFileId,'time_8byte',DFNT_FLOAT64,1,ttime) time_4byte = real(ttime,4) iStatus = sfsnatt(iFileId,'time',DFNT_FLOAT32,1,time_4byte) !Tilt angle #ifdef DEBUG_MODE_ON write(6,*) ' Writing tilt angle' #endif iStatus = sfsattr(iFileId,'tilt_angle',DFNT_FLOAT32,1, $ tilt_angle) ! TZERO (defined in boundx.inc) #ifdef DEBUG_MODE_ON write(6,*) ' Writing tzero' #endif iStatus = sfsnatt(iFileId, 'tzero', DFNT_FLOAT32,1,tzero) ! Run Descriptor iLen=index(run_label,'##')+1 #ifdef DEBUG_MODE_ON write(6,*) ' Writing run descriptor >',run_label(1:iLen) #endif c iStatus = sfscatt(iFileId,'run_descriptor',DFNT_CHAR8, iStatus = sfscatt(iFileId,'run_descriptor',DFNT_CHAR8, $ iLen,run_label) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! * Use properties (svn:keywords) to add revision meta data to HDF file. * http://svnbook.red-bean.com/en/1.1/ch07s02.html * * Subversion defines five variables: * - Date * - Revision * - Author * - HeadURL * - Id (a combination of the above) * * These will auto-updated when the property is set for a source file: * * svn propset svn:keywords "Id" [filename] * * For now, we use the Id... * * Where's $GlobalRev$? * http://svnbook.red-bean.com/en/1.4/svn.advanced.props.special.keywords.html * * Set Global Revision via method described here: * http://subversion.tigris.org/faq.html#version-value-in-source * * See also * - MIX/src/IO.C * - LFM-para/src/hdfdump-para.F * - LFM-para/src/iondump-para.F * revision_str = |"$Id: hdfdump-para.F 1972 2012-05-09 22:04:49Z schmitt $\0" iLen=LNBLNK_OR_LEN_TRIM(revision_str) #ifdef DEBUG_MODE_ON write(6,*) ' Writing I/O Revision string >',revision_str(1:iLen) #endif iStatus = sfscatt(iFileId,'I/O Revision',DFNT_CHAR8, $ iLen,revision_str) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! revision_str = ! | REPOSITORY_REVISION_NUMBER ! ^^^^^^^^^^_^^^^^^^^_^^^^^^ (preprocessor flag from Makefile) iLen=LNBLNK_OR_LEN_TRIM(REPO_REV) #ifdef DEBUG_MODE_ON write(6,*) ' Writing Repository Revision string >', $ revision_str(1:iLen) #endif iStatus = sfscatt(iFileId,'Repository Revision',DFNT_CHAR8, $ iLen,REPO_REV) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Content description write(caCont, 100) Ni_global,Nj_global,Nk_global, No 100 format('3D-MHD ',i3,' ',i3,' ',i3,' ',i3) iLen=LNBLNK_OR_LEN_TRIM(caCont) caCont(iLen+1:iLen+2) = LF0 #ifdef DEBUG_MODE_ON write(6,*) ' Writing file contents' #endif c iStatus = sfscatt(iFileId,'file_contents',DFNT_CHAR8, iStatus = sfscatt(iFileId,'file_contents',DFNT_CHAR8, + iLen+2,caCont) ! Dipole strength (very important for subdipol write(caCont, 101) geoqmu 101 format('Geoqmu (cgs) = ',1pe16.7) iLen=LNBLNK_OR_LEN_TRIM(caCont) caCont(iLen+1:ilen+2) = LF0 #ifdef DEBUG_MODE_ON write(6,*) ' Writing dipole moment' #endif c iStatus = sfscatt iStatus = sfsattr(iFileId,'dipole_moment',DFNT_CHAR8, + iLen+2,caCont) !Written by #ifdef DEBUG_MODE_ON write(6,*) ' Writing written by' #endif c iStatus = sfscatt(iFileId,'written_by',DFNT_CHAR8, iStatus = sfsattr(iFileId,'written_by',DFNT_CHAR8, + 12,'PARA-FORTRAN') !Run parameters eventually write(caCont,150) 'Not yet used!' 150 format(a) iLen=LNBLNK_OR_LEN_TRIM(caCont) iaStride1d(1)=1 iaStart1d(1)=0 iaEdge1d(1)=iLen iaDim1d(1)=iLen iRank=1 iSecId=sfcreate(iFileId,'run_params',DFNT_CHAR8,iRank,iaDim1d) c iStatus = sfwcdata(iSecId,iaStart1d,iaStride1d,iaEdge1d, iStatus = sfwdata(iSecId,iaStart1d,iaStride1d,iaEdge1d, + caCont) iStatus = sfendacc(iSecId) c c c get the namelist so it can be used as a file attribute c c open(unit=81,file='INPUT1',form='formatted') c istart =1 do kku = 1,500 read(81,901,end=1771) liner 901 format(A) llen = blnk_len(liner,120) istop = istart+llen+2 namer(istart:istop) = liner(1:llen)//' # ' istart = istop+1 c enddo 1771 continue c close(unit=81) c c update run_history attribute c iLen=index(run_start,'##')+1 llen = blnk_len(run_history,2048) run_history(llen+1:llen+iLen) = run_start(1:iLen) c c mhd_open_write_hdf = iStatus c return c c entry HDFDUMP_VAR(VARNAME, dumvar,nsize_i,nsize_j,nsize_k, $ npad,llstep,tttime,GRID,units) c c check for I/O processor c if ( mype .ne. 0 ) return c c c c c ! In this format each variable is its own SDS iRank=3 iaDim3d(1) = nsize_i iaDim3d(2) = nsize_j iaDim3d(3) = nsize_k do i=1,3 iaStride3d(i)=1 iaStart3d(i)=0 iaEdge3d(i)= iaDim3d(i) enddo len = index(VARNAME,char(0))-1 call rststr(caSec) caSec(1:len) = VARNAME(1:len) if ( GRID ) then caSec(len+1:len+4) = 'grid' len = len+4 endif name_start =12*(variable_number) + 1 name_stop = name_start + min(12,len) varname_list(name_start:name_stop) = caSec(1:min(12,len)) variable_number = variable_number +1 iSecId=sfcreate(iFileId,caSec,DFNT_FLOAT32,iRank,iaDim3d) c load the array dimensions iStatus = sfsattr(iSecId,'ni',DFNT_INT32,1,nsize_i) iStatus = sfsattr(iSecId,'nj',DFNT_INT32,1,nsize_j) iStatus = sfsattr(iSecId,'nk',DFNT_INT32,1,nsize_k) c iLen = index(units,char(0))-1 !add units as variable attribute iStatus = sfsattr(iSecId,'units',DFNT_CHAR8,iLen,units) allocate(dummy_hdf(nsize_i,nsize_j,nsize_k)) do k=1,nsize_k do j=1,nsize_j do i=1,nsize_i dummy_hdf(i,j,k) = dumvar(i,j,k) enddo enddo enddo !output the varible data iStatus = sfwdata(iSecId,iaStart3d,iaStride3d,iaEdge3d, $ dummy_hdf) iStatus = sfendacc(iSecId) hdfdump_var = iStatus deallocate(dummy_hdf) return c c c entry hdfdump_close !close file on last dump c c check to see if this is the I/O processor c c >jgl test write (9,1910) mype 1910 format ('In hdf_close ',i3) if ( mype .ne. 0 ) then iStatus= 0 else iRank=1 iaDim1d(1) = 12*variable_number iaStride1d(1)=1 iaStart1d(1)=0 iaEdge1d(1)= iaDim1d(1) c iSecId=sfcreate(iFileId,'variable list',DFNT_CHAR8, $ iRank,iaDim1d) c c iStatus = sfwdata(iSecId,iaStart1d,iaStride1d,iaEdge1d, $ varname_list) iStatus = sfsattr(iSecId,'number of variables output', $ DFNT_INT32,1,variable_number) iStatus = sfendacc(iSecId) c c iStatus = sfend(iFileId) endif c hdfdump_close = iStatus ! ... End function mhd_open_write_hdf .................................. return end !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !> info_out !! integer function info_out(iFileId,name,string) ! ... Local variables .................................................. #include "hdf.inc" c function type declarations integer sfstart, sfend, sfscatt, sfcreate, sfwcdata integer sfwdata, sfendacc, sfsnatt integer sfsattr, sfrattr ! ... Parameter Variables .............................................. character*(*) name,string ! ! ... Begin ............................................................ ! #ifdef DEBUG_MODE_ON write(*,*) "DEBUG: in hdfdump-para.F::info_out()" #endif iLen=LNBLNK_OR_LEN_TRIM(string) iaStride1d=1 iaStart1d=0 iaEdge1d=iLen iaDim1d=iLen iRank=1 jlen = LNBLNK_OR_LEN_TRIM(name) itest = DFNT_CHAR8 iSecId=sfcreate(iFileId,name(1:jlen),DFNT_CHAR8, $ iRank,iaDim1d) c iStatus = sfwcdata(iSecId,iaStart1d,iaStride1d,iaEdge1d, iStatus = sfwdata(iSecId,iaStart1d,iaStride1d,iaEdge1d, + string) iStatus = sfendacc(iSecId) c info_out = iStatus ! ... End function info_out(iFileId,name,string) ....................... return end !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !> INT2STR !! Convert integer value to a string. Store the results in CAOUT SUBROUTINE INT2STR(CAOUT,IVALUE,IBEGIN,IEND) ! ... Local Variables .................................................. integer i,iStart,iLast character*20 caDum ! ... Parameter Variables .............................................. character*(*) caout !> Character array containing a string of integer iValue integer iValue !> Integer to convert to string integer iBegin !> First index of output string integer iEnd !> Last index of output string ! ! ... Begin ............................................................ ! #ifdef DEBUG_MODE_ON write(*,*) "DEBUG: in hdfdump-para.F::INT2STR(...)" #endif write(caDum,10) iValue 10 format(i8) iStart = 1 do while( caDum(iStart:iStart) .eq. ' ' ) iStart = iStart + 1 enddo iLast = LNBLNK_OR_LEN_TRIM(caDum) caOut(1:iLast-iStart+1) = caDum(iStart:iLast) iBegin = 1 iEnd = iLast - iStart + 1 ! ! ... End subroutine INT2STR(CAOUT,IVALUE,IBEGIN,IEND) ................. return end !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !> FLT2STR !! Convert floating opint RVALUE to a string CAOUT SUBROUTINE FLT2STR(CAOUT,RVALUE,IBEGIN,IEND) ! ... Local variables .................................................. integer i,iStart,iLast character*20 caDum ! ... Parameter Variables .............................................. character*(*) caout !> Character array containing a string of floating-point rValue real rValue !> Floating point number to convert to string integer iBegin !> First index of output string integer iEnd !> Last index of output string ! ! ... Begin ............................................................ ! #ifdef DEBUG_MODE_ON write(*,*) "DEBUG: in hdfdump-para.F::FLT2STR(...)" #endif write(caDum,10) rValue 10 format(1pe16.7) iStart = 1 do while( caDum(iStart:iStart) .eq. ' ' ) iStart = iStart + 1 enddo iLast = LNBLNK_OR_LEN_TRIM(caDum) caOut(1:iLast-iStart+1) = caDum(iStart:iLast) iBegin = 1 iEnd = iLast - iStart + 1 ! ! ... End subroutine FLT2STR(...) ...................................... ! return end !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !> RSTSTR(CAOUT) - Reset String !! !! Sets every character in CAOUT to the character corresponding to ASCII !! code "0". !! SUBROUTINE RSTSTR(CAOUT) ! ... Parameter Variable ............................................... character*(*) caOut !> Character array to reset ! ! ... Begin ............................................................ ! #ifdef DEBUG_MODE_ON write(*,*) "DEBUG: in hdfdump-para.F::RSTSTR(...)" #endif iLen=len(caOut) do i=1,iLen c caOut(i:i)="\0" caOut(i:i)= achar(0) enddo ! ... End SUBROUTINE RSTSTR(CAOUT) ..................................... return end !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !> SAMERUN(a,b) !! Returns true if run (a) and (b) have the same input name logical function SAMERUN(a,b) ! ... Parameter Variables .............................................. character*(*) a !> String to first filename character*(*) b !> String to second filename ! ! ... Begin ............................................................ ! #ifdef DEBUG_MODE_ON write(*,*) "DEBUG: in hdfdump-para.F::SAMERUN(...)" #endif lla = index(a,'##') llb = index(b,'##') if ( lla .eq. llb ) then samerun = .true. do i=1,lla if (a(i:i) .ne. b(i:i)) samerun=.false. enddo else samerun = .false. endif ! ... End function SAMERUN(a,b)......................................... return end !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !> blnk_len(a,n) !! Finds the number of blanks in string a of length n integer function blnk_len(a,n) * integer blnk_len ! ... Parameter Variables .............................................. character*(*) a ! ! ... Begin ............................................................ ! #ifdef DEBUG_MODE_ON write(*,*) "DEBUG: in hdfdump-para.F::blnk_len(...)" #endif do kk=n,1,-1 if ( a(kk:kk) .ne. ' ') then blnk_len = kk go to 1001 endif enddo blnk_len=1 1001 continue ! ... End function blnk_len(a,n) ....................................... return end !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!