C $Header: /u/gcmpack/MITgcm/pkg/fizhi/fizhi_readwrite_vegtiles.F,v 1.20 2009/06/28 01:05:41 jmc Exp $ C $Name: $ #include "FIZHI_OPTIONS.h" C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| CBOP C !ROUTINE: FIZHI_WRITE_VEGTILES C !INTERFACE: SUBROUTINE FIZHI_WRITE_VEGTILES(fn,pickupflg,myTime,myIter,myThid) C !DESCRIPTION: C !USES: IMPLICIT NONE #include "SIZE.h" #include "fizhi_SIZE.h" #include "fizhi_land_SIZE.h" #include "fizhi_coms.h" #include "fizhi_land_coms.h" #include "fizhi_earth_coms.h" #include "EEPARAMS.h" #include "PARAMS.h" #ifdef ALLOW_MNC #include "MNC_PARAMS.h" #endif #ifdef ALLOW_EXCH2 #include "W2_EXCH2_SIZE.h" #include "W2_EXCH2_TOPOLOGY.h" #endif /* ALLOW_EXCH2 */ EXTERNAL INTEGER ILNBLNK INTEGER MDS_RECLEN C !INPUT/OUTPUT PARAMETERS: CHARACTER*(*) fn INTEGER pickupflg _RL myTime INTEGER myIter INTEGER myThid CEOP C !LOCAL VARIABLES: CHARACTER*1 prec CHARACTER*80 bnam character*(80) dataFName integer ilst integer i,k,n integer ig,jg,tn,iunit integer length_of_rec integer bi,bj,irec,fileprec Real*8 r8seg(nchp) C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| DO i = 1,80 bnam(i:i) = ' ' ENDDO ilst = ILNBLNK(fn) if (pickupflg.eq.0) then prec = 'D' fileprec = 64 WRITE(bnam,'(a,a)') 'pickup_vegtiles.', fn(1:ilst) else prec = 'D' fileprec = 64 WRITE(bnam,'(a,a)') 'state_vegtiles.', fn(1:ilst) endif #ifdef ALLOW_MNC IF (useMNC.AND. pickup_write_mnc) THEN C Write fizhi veg-space variables using the MNC package CALL MNC_CW_SET_UDIM(bnam, 1, myThid) CALL MNC_CW_RL_W_S('D',bnam,0,0,'T', myTime, myThid) CALL MNC_CW_I_W_S('I',bnam,0,0,'iter',myIter,myThid) C fizhi_coms.h CALL MNC_CW_RL_W(prec,bnam,0,0,'ctmt', ctmt, myThid) CALL MNC_CW_RL_W(prec,bnam,0,0,'xxmt', xxmt, myThid) CALL MNC_CW_RL_W(prec,bnam,0,0,'yymt', yymt, myThid) CALL MNC_CW_RL_W(prec,bnam,0,0,'zetamt', zetamt, myThid) CALL MNC_CW_RL_W(prec,bnam,0,0,'xlmt', xlmt, myThid) CALL MNC_CW_RL_W(prec,bnam,0,0,'khmt', khmt, myThid) CALL MNC_CW_RL_W(prec,bnam,0,0,'tke', tke, myThid) C fizhi_land_coms.h CALL MNC_CW_RL_W(prec,bnam,0,0,'tcanopy', tcanopy, myThid) CALL MNC_CW_RL_W(prec,bnam,0,0,'tdeep', tdeep, myThid) CALL MNC_CW_RL_W(prec,bnam,0,0,'ecanopy', ecanopy, myThid) CALL MNC_CW_RL_W(prec,bnam,0,0,'swetshal', swetshal, myThid) CALL MNC_CW_RL_W(prec,bnam,0,0,'swetroot', swetroot, myThid) CALL MNC_CW_RL_W(prec,bnam,0,0,'swetdeep', swetdeep, myThid) CALL MNC_CW_RL_W(prec,bnam,0,0,'snodep', snodep, myThid) CALL MNC_CW_RL_W(prec,bnam,0,0,'capac', capac, myThid) CALL MNC_CW_RL_W(prec,bnam,0,0,'chlt', chlt, myThid) CALL MNC_CW_RL_W(prec,bnam,0,0,'chlon', chlon, myThid) CALL MNC_CW_I_W('I',bnam,0,0,'igrd', igrd, myThid) C fizhi_earth_coms.h CALL MNC_CW_I_W('I',bnam,0,0,'ityp', ityp, myThid) CALL MNC_CW_RL_W(prec,bnam,0,0,'chfr', chfr, myThid) ENDIF #endif /* Not ALLOW_MNC sequence */ call MDSFINDUNIT( iunit, mythid ) length_of_rec=MDS_RECLEN( fileprec, nchp, mythid ) DO bj = myByLo(myThid), myByHi(myThid) DO bi = myBxLo(myThid), myBxHi(myThid) #ifdef ALLOW_EXCH2 tn = W2_myTileList(bi,bj) iG = tn jG = 1 #else iG = bi+(myXGlobalLo-1)/sNx jG = bj+(myYGlobalLo-1)/sNy tn = (jG - 1)*(nPx*nSx) + iG #endif /* ALLOW_EXCH2 */ write(dataFname(1:80),'(a,2a,i3.3,a,i3.3,a)') & 'pickup_vegtiles.',fn(1:ilst),'.',iG,'.',jG,'.data' open( iUnit, file=dataFName, status='unknown', & access='direct', recl=length_of_rec ) C First write single-level turbulence fields do n = 1,nchp r8seg(n) = ctmt(n,bi,bj) enddo #ifdef _BYTESWAPIO call MDS_BYTESWAPR8( nchp, r8seg ) #endif write(iunit,rec=1) r8seg do n = 1,nchp r8seg(n) = xxmt(n,bi,bj) enddo #ifdef _BYTESWAPIO call MDS_BYTESWAPR8( nchp, r8seg ) #endif write(iunit,rec=2) r8seg do n = 1,nchp r8seg(n) = yymt(n,bi,bj) enddo #ifdef _BYTESWAPIO call MDS_BYTESWAPR8( nchp, r8seg ) #endif write(iunit,rec=3) r8seg do n = 1,nchp r8seg(n) = zetamt(n,bi,bj) enddo #ifdef _BYTESWAPIO call MDS_BYTESWAPR8( nchp, r8seg ) #endif write(iunit,rec=4) r8seg C And now write Multi-level turbulence fields do k = 1,Nrphys do n = 1,nchp r8seg(n) = xlmt(n,k,bi,bj) enddo #ifdef _BYTESWAPIO call MDS_BYTESWAPR8( nchp, r8seg ) #endif irec = 4 + 0*Nrphys + k write(iunit,rec=irec) r8seg enddo do k = 1,Nrphys do n = 1,nchp r8seg(n) = khmt(n,k,bi,bj) enddo #ifdef _BYTESWAPIO call MDS_BYTESWAPR8( nchp, r8seg ) #endif irec = 4 + 1*Nrphys + k write(iunit,rec=irec) r8seg enddo do k = 1,Nrphys do n = 1,nchp r8seg(n) = tke(n,k,bi,bj) enddo #ifdef _BYTESWAPIO call MDS_BYTESWAPR8( nchp, r8seg ) #endif irec = 4 + 2*Nrphys + k write(iunit,rec=irec) r8seg enddo C And finally, write land surface fields do n = 1,nchp r8seg(n) = tcanopy(n,bi,bj) enddo #ifdef _BYTESWAPIO call MDS_BYTESWAPR8( nchp, r8seg ) #endif irec = 4 + 3*Nrphys + 1 write(iunit,rec=irec) r8seg do n = 1,nchp r8seg(n) = tdeep(n,bi,bj) enddo #ifdef _BYTESWAPIO call MDS_BYTESWAPR8( nchp, r8seg ) #endif irec = 4 + 3*Nrphys + 2 write(iunit,rec=irec) r8seg do n = 1,nchp r8seg(n) = ecanopy(n,bi,bj) enddo #ifdef _BYTESWAPIO call MDS_BYTESWAPR8( nchp, r8seg ) #endif irec = 4 + 3*Nrphys + 3 write(iunit,rec=irec) r8seg do n = 1,nchp r8seg(n) = swetshal(n,bi,bj) enddo #ifdef _BYTESWAPIO call MDS_BYTESWAPR8( nchp, r8seg ) #endif irec = 4 + 3*Nrphys + 4 write(iunit,rec=irec) r8seg do n = 1,nchp r8seg(n) = swetroot(n,bi,bj) enddo #ifdef _BYTESWAPIO call MDS_BYTESWAPR8( nchp, r8seg ) #endif irec = 4 + 3*Nrphys + 5 write(iunit,rec=irec) r8seg do n = 1,nchp r8seg(n) = swetdeep(n,bi,bj) enddo #ifdef _BYTESWAPIO call MDS_BYTESWAPR8( nchp, r8seg ) #endif irec = 4 + 3*Nrphys + 6 write(iunit,rec=irec) r8seg do n = 1,nchp r8seg(n) = snodep(n,bi,bj) enddo #ifdef _BYTESWAPIO call MDS_BYTESWAPR8( nchp, r8seg ) #endif irec = 4 + 3*Nrphys + 7 write(iunit,rec=irec) r8seg do n = 1,nchp r8seg(n) = capac(n,bi,bj) enddo #ifdef _BYTESWAPIO call MDS_BYTESWAPR8( nchp, r8seg ) #endif irec = 4 + 3*Nrphys + 8 write(iunit,rec=irec) r8seg close(iunit) C End of bi bj loop enddo enddo RETURN END
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| CBOP C !ROUTINE: FIZHI_READ_VEGTILES C !INTERFACE: SUBROUTINE FIZHI_READ_VEGTILES(Iter,prec,myThid) C !DESCRIPTION: C !USES: IMPLICIT NONE #include "SIZE.h" #include "fizhi_SIZE.h" #include "fizhi_land_SIZE.h" #include "fizhi_coms.h" #include "fizhi_land_coms.h" #include "fizhi_earth_coms.h" #include "EEPARAMS.h" #include "PARAMS.h" #ifdef ALLOW_MNC #include "MNC_PARAMS.h" #endif #ifdef ALLOW_EXCH2 #include "W2_EXCH2_SIZE.h" #include "W2_EXCH2_TOPOLOGY.h" #endif /* ALLOW_EXCH2 */ EXTERNAL INTEGER ILNBLNK INTEGER MDS_RECLEN C !INPUT/OUTPUT PARAMETERS: CHARACTER*1 prec INTEGER Iter INTEGER myThid CEOP C !LOCAL VARIABLES: CHARACTER*80 fn CHARACTER*80 bnam integer ilst character*(80) dataFName integer i,k,n integer ig,jg,tn,iunit integer length_of_rec integer bi,bj,irec,fileprec Real*8 r8seg(nchp) DO i = 1,80 bnam(i:i) = ' ' ENDDO WRITE(fn,'(a,I10.10)') 'pickup_vegtiles.',Iter ilst = ILNBLNK(fn) WRITE(bnam,'(a,I10.10)') 'pickup_vegtiles.',Iter fileprec = 64 #ifdef ALLOW_MNC IF (useMNC.AND. pickup_write_mnc) THEN C Write fizhi veg-space variables using the MNC package CALL MNC_FILE_CLOSE_ALL_MATCHING(bnam, myThid) CALL MNC_CW_SET_UDIM(bnam, 1, myThid) C fizhi_coms.h CALL MNC_CW_RL_R(prec,bnam,0,0,'ctmt', ctmt, myThid) CALL MNC_CW_RL_R(prec,bnam,0,0,'xxmt', xxmt, myThid) CALL MNC_CW_RL_R(prec,bnam,0,0,'yymt', yymt, myThid) CALL MNC_CW_RL_R(prec,bnam,0,0,'zetamt', zetamt, myThid) CALL MNC_CW_RL_R(prec,bnam,0,0,'xlmt', xlmt, myThid) CALL MNC_CW_RL_R(prec,bnam,0,0,'khmt', khmt, myThid) CALL MNC_CW_RL_R(prec,bnam,0,0,'tke', tke, myThid) C fizhi_land_coms.h CALL MNC_CW_RL_R(prec,bnam,0,0,'tcanopy', tcanopy, myThid) CALL MNC_CW_RL_R(prec,bnam,0,0,'tdeep', tdeep, myThid) CALL MNC_CW_RL_R(prec,bnam,0,0,'ecanopy', ecanopy, myThid) CALL MNC_CW_RL_R(prec,bnam,0,0,'swetshal', swetshal, myThid) CALL MNC_CW_RL_R(prec,bnam,0,0,'swetroot', swetroot, myThid) CALL MNC_CW_RL_R(prec,bnam,0,0,'swetdeep', swetdeep, myThid) CALL MNC_CW_RL_R(prec,bnam,0,0,'snodep', snodep, myThid) CALL MNC_CW_RL_R(prec,bnam,0,0,'capac', capac, myThid) ENDIF #endif /* Not ALLOW_MNC sequence */ call MDSFINDUNIT( iunit, mythid ) length_of_rec=MDS_RECLEN( fileprec, nchp, mythid ) DO bj = myByLo(myThid), myByHi(myThid) DO bi = myBxLo(myThid), myBxHi(myThid) #ifdef ALLOW_EXCH2 tn = W2_myTileList(bi,bj) iG = tn jG = 1 #else iG = bi+(myXGlobalLo-1)/sNx jG = bj+(myYGlobalLo-1)/sNy tn = (jG - 1)*(nPx*nSx) + iG #endif /* ALLOW_EXCH2 */ write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)') & fn(1:ilst),'.',iG,'.',jG,'.data' print *,' Opening ',dataFName open( iUnit, file=dataFName, status='old', & access='direct', recl=length_of_rec ) irec = 0 C First read single-level turbulence fields read(iunit,rec=1) r8seg #ifdef _BYTESWAPIO call MDS_BYTESWAPR8( nchp, r8seg ) #endif do n = 1,nchp ctmt(n,bi,bj) = r8seg(n) enddo read(iunit,rec=2) r8seg #ifdef _BYTESWAPIO call MDS_BYTESWAPR8( nchp, r8seg ) #endif do n = 1,nchp xxmt(n,bi,bj) = r8seg(n) enddo read(iunit,rec=3) r8seg #ifdef _BYTESWAPIO call MDS_BYTESWAPR8( nchp, r8seg ) #endif do n = 1,nchp yymt(n,bi,bj) = r8seg(n) enddo read(iunit,rec=4) r8seg #ifdef _BYTESWAPIO call MDS_BYTESWAPR8( nchp, r8seg ) #endif do n = 1,nchp zetamt(n,bi,bj) = r8seg(n) enddo C And now read Multi-level turbulence fields do k = 1,Nrphys irec = 4 + 0*Nrphys + k read(iunit,rec=irec) r8seg #ifdef _BYTESWAPIO call MDS_BYTESWAPR8( nchp, r8seg ) #endif do n = 1,nchp xlmt(n,k,bi,bj) = r8seg(n) enddo enddo do k = 1,Nrphys irec = 4 + 1*Nrphys + k read(iunit,rec=irec) r8seg #ifdef _BYTESWAPIO call MDS_BYTESWAPR8( nchp, r8seg ) #endif do n = 1,nchp khmt(n,k,bi,bj) = r8seg(n) enddo enddo do k = 1,Nrphys irec = 4 + 2*Nrphys + k read(iunit,rec=irec) r8seg #ifdef _BYTESWAPIO call MDS_BYTESWAPR8( nchp, r8seg ) #endif do n = 1,nchp tke(n,k,bi,bj) = r8seg(n) enddo enddo C And finally, read land surface fields irec = 4 + 3*Nrphys + 1 read(iunit,rec=irec) r8seg #ifdef _BYTESWAPIO call MDS_BYTESWAPR8( nchp, r8seg ) #endif do n = 1,nchp tcanopy(n,bi,bj) = r8seg(n) enddo irec = 4 + 3*Nrphys + 2 read(iunit,rec=irec) r8seg #ifdef _BYTESWAPIO call MDS_BYTESWAPR8( nchp, r8seg ) #endif do n = 1,nchp tdeep(n,bi,bj) = r8seg(n) enddo irec = 4 + 3*Nrphys + 3 read(iunit,rec=irec) r8seg #ifdef _BYTESWAPIO call MDS_BYTESWAPR8( nchp, r8seg ) #endif do n = 1,nchp ecanopy(n,bi,bj) = r8seg(n) enddo irec = 4 + 3*Nrphys + 4 read(iunit,rec=irec) r8seg #ifdef _BYTESWAPIO call MDS_BYTESWAPR8( nchp, r8seg ) #endif do n = 1,nchp swetshal(n,bi,bj) = r8seg(n) enddo irec = 4 + 3*Nrphys + 5 read(iunit,rec=irec) r8seg #ifdef _BYTESWAPIO call MDS_BYTESWAPR8( nchp, r8seg ) #endif do n = 1,nchp swetroot(n,bi,bj) = r8seg(n) enddo irec = 4 + 3*Nrphys + 6 read(iunit,rec=irec) r8seg #ifdef _BYTESWAPIO call MDS_BYTESWAPR8( nchp, r8seg ) #endif do n = 1,nchp swetdeep(n,bi,bj) = r8seg(n) enddo irec = 4 + 3*Nrphys + 7 read(iunit,rec=irec) r8seg #ifdef _BYTESWAPIO call MDS_BYTESWAPR8( nchp, r8seg ) #endif do n = 1,nchp snodep(n,bi,bj) = r8seg(n) enddo irec = 4 + 3*Nrphys + 8 read(iunit,rec=irec) r8seg #ifdef _BYTESWAPIO call MDS_BYTESWAPR8( nchp, r8seg ) #endif do n = 1,nchp capac(n,bi,bj) = r8seg(n) enddo close(iunit) C End of bi bj loop enddo enddo RETURN END
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|