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-|--+----|