pkg/aim_v23/aim_write_phys.F

7f9e3ec2e7 Jean*0001 #include "AIM_OPTIONS.h"
                0002
                0003 CBOP
                0004 C     !ROUTINE: AIM_WRITE_PHYS
                0005 C     !INTERFACE:
                0006       SUBROUTINE AIM_WRITE_PHYS(
                0007      I               pref, suff, nNr, field,
                0008      I               kLev, bi, bj, iRec, myIter, myThid )
                0009 C     !DESCRIPTION: \bv
                0010 C     *==========================================================*
                0011 C     | SUBROUTINE AIM_WRITE_PHYS
                0012 C     | o Write variable from AIM physics common block
                0013 C     |   (=> no overlap & nThreads) and reverse K index.
                0014 C     *==========================================================*
                0015 C     | Note: assume symetry in tiles per thread treatment
                0016 C     *==========================================================*
                0017 C     !USES
                0018       IMPLICIT NONE
                0019
                0020 C     == Global variables ===
                0021 #include "AIM_SIZE.h"
                0022
                0023 #include "EEPARAMS.h"
                0024 c #include "PARAMS.h"
                0025
                0026 C     !INPUT/OUTPUT PARAMETERS:
                0027 C     == Routine arguments ==
                0028 C     pref   :: Prefix of the output file name
                0029 C     suff   :: Suffix of the output file name
                0030 C     nNr    :: 3rd dim. of the input field
                0031 C     field  :: Field (from aim-physics) to write
                0032 C     kLev   :: level index to write (0 = write all levels)
                0033 C     bi,bj  :: Tile index
                0034 C     iRec   :: reccord number in the output file
                0035 C     myIter :: Current iteration number in simulation
ed4109f4a2 Jean*0036 C     myThid :: my Thread Id number
7f9e3ec2e7 Jean*0037       CHARACTER*(*) pref, suff
                0038       INTEGER nNr
                0039       _RL field(sNx,sNy,nNr,MAX_NO_THREADS)
                0040       INTEGER kLev, bi, bj, iRec, myIter, myThid
                0041
                0042 #ifdef ALLOW_AIM
                0043
                0044 C Functions
                0045       INTEGER  ILNBLNK
                0046       EXTERNAL ILNBLNK
                0047
                0048 C     !LOCAL VARIABLES:
                0049       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0050       _RL tmpFld(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr)
                0051       INTEGER iL
                0052       INTEGER i, j, k, Katm, nLoc
                0053       INTEGER ith, biLoc, bjLoc
                0054 CEOP
                0055
                0056 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0057
                0058 #ifdef LOCBIN_IO_THREAD_SAFE
                0059 C-    safe for any thread to do IO
                0060       ith = myThid
                0061       biLoc = bi
                0062       bjLoc = bj
                0063 #else /* LOCBIN_IO_THREAD_SAFE */
                0064 C-    master-thread does IO for all threads
                0065       _BARRIER
                0066       _BEGIN_MASTER( myThid )
                0067       DO ith=1,nThreads
                0068         biLoc = bi + myBxLo(ith) - 1
                0069         bjLoc = bj + myByLo(ith) - 1
                0070 #endif /* LOCBIN_IO_THREAD_SAFE */
                0071
                0072 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0073
                0074 C--   Check for argument list consistency
                0075         IF ( nNr.LT.1 .OR. nNr.GT.Nr ) THEN
                0076           iL = ILNBLNK( pref )
                0077           WRITE(msgBuf,'(A,I10,A,2I5,A,I4,2A)')
                0078      &      'AIM_WRITE_PHYS (it=', myIter, ' bi,bj=', bi,bj,
                0079      &      ' iRec=', iRec, ' ): try to write: ', pref(1:iL)
                0080           CALL PRINT_ERROR( msgBuf, myThid )
                0081           WRITE(msgBuf,'(A,I4,A,I4)')
                0082      &      'AIM_WRITE_PHYS: 3rd dim.(field)=',nNr,' has to be <',Nr
                0083           CALL PRINT_ERROR( msgBuf , myThid)
                0084           STOP 'ABNORMAL END: S/R AIM_WRITE_PHYS'
                0085         ELSEIF ( kLev.NE.0 .AND. kLev.GT.nNr ) THEN
                0086           iL = ILNBLNK( pref )
                0087           WRITE(msgBuf,'(A,I10,A,2I5,A,I4,2A)')
                0088      &      'AIM_WRITE_PHYS (it=', myIter, ' bi,bj=', bi,bj,
                0089      &      ' iRec=', iRec, ' ): try to write: ', pref(1:iL)
                0090           CALL PRINT_ERROR( msgBuf, myThid )
                0091           WRITE(msgBuf,'(A,I4,A,I4)')
                0092      &     'AIM_WRITE_PHYS: kLev=', kLev,
                0093      &     ' out of bounds (dim=', nNr,' )'
                0094           CALL PRINT_ERROR( msgBuf , myThid)
                0095           STOP 'ABNORMAL END: S/R AIM_WRITE_PHYS'
                0096         ENDIF
                0097
                0098 C--   Copy the input field into tempo. array:
                0099         nLoc = nNr
                0100         IF ( kLev.GE.1 .AND. kLev.LE.nNr ) THEN
                0101           nLoc = 1
                0102           DO j=1,sNy
                0103            DO i=1,sNx
                0104             tmpFld(i,j,1) = field(i,j,kLev,ith)
                0105            ENDDO
                0106           ENDDO
                0107         ELSEIF (nNr.EQ.Nr) THEN
                0108 C-     Reverse K index:
                0109          DO k=1,Nr
                0110           Katm = _KD2KA( k )
                0111           DO j=1,sNy
                0112            DO i=1,sNx
                0113             tmpFld(i,j,k) = field(i,j,Katm,ith)
                0114            ENDDO
                0115           ENDDO
                0116          ENDDO
                0117         ELSE
                0118 C-     Do simple copy
                0119          DO k=1,nNr
                0120           DO j=1,sNy
                0121            DO i=1,sNx
                0122             tmpFld(i,j,k) = field(i,j,k,ith)
                0123            ENDDO
                0124           ENDDO
                0125          ENDDO
                0126         ENDIF
                0127
ed4109f4a2 Jean*0128 C--   Write to file: note: call with myThArg=0 => single thread job
7f9e3ec2e7 Jean*0129         CALL WRITE_LOCAL_RL( pref, suff, nLoc, tmpFld,
ed4109f4a2 Jean*0130      &                       biLoc, bjLoc, iRec, myIter, 0 )
7f9e3ec2e7 Jean*0131
                0132 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0133
                0134 #ifndef LOCBIN_IO_THREAD_SAFE
                0135       ENDDO
                0136       _END_MASTER( myThid )
                0137       _BARRIER
                0138 #endif /* ndef LOCBIN_IO_THREAD_SAFE */
                0139
                0140 #endif /* ALLOW_AIM */
                0141       RETURN
                0142       END