hs94.1x64x5/code_oad/ctrl_map_gentim2d.F

e9a88bebd8 Patr*0001 #include "CTRL_OPTIONS.h"
                0002
                0003 CBOP
                0004 C     !ROUTINE: CTRL_MAP_GENTIM2D
                0005 C     !INTERFACE:
                0006       SUBROUTINE CTRL_MAP_GENTIM2D(
                0007      I                        myTime, myIter, myThid )
                0008 C     !DESCRIPTION: \bv
                0009 C     *=============================================================*
                0010 C     | S/R  CTRL_MAP_GENTIM2D
                0011 C     *=============================================================*
                0012
                0013 C     !USES:
                0014       IMPLICIT NONE
                0015
                0016 C     === Global variables ===
                0017 #include "SIZE.h"
                0018 #include "EEPARAMS.h"
                0019 #include "PARAMS.h"
                0020 #include "FFIELDS.h"
                0021 #include "DYNVARS.h"
                0022 #include "GRID.h"
                0023 #include "CTRL_SIZE.h"
4d72283393 Mart*0024 #include "CTRL.h"
e9a88bebd8 Patr*0025 #include "CTRL_GENARR.h"
edcd27be69 Mart*0026 #include "CTRL_DUMMY.h"
65754df434 Mart*0027 #include "OPTIMCYCLE.h"
e9a88bebd8 Patr*0028 #ifdef ALLOW_AUTODIFF
                0029 #include "AUTODIFF_MYFIELDS.h"
                0030 #endif
                0031
                0032 C     !INPUT/OUTPUT PARAMETERS:
                0033 C     === Routine arguments ===
                0034 C     myIter :: iteration counter for this thread
                0035 C     myTime :: time counter for this thread
                0036 C     myThid :: thread number for this instance of the routine.
                0037       _RL  myTime
                0038       INTEGER myIter
                0039       INTEGER myThid
                0040
                0041 C     !LOCAL VARIABLES:
                0042 C     == Local variables ==
                0043       integer bi,bj
                0044       integer i,j,k
                0045       integer itlo,ithi
                0046       integer jtlo,jthi
                0047       integer jmin,jmax
                0048       integer imin,imax
                0049       integer il
                0050       integer iarr
                0051
                0052       logical equal
                0053       logical doglobalread
                0054       logical ladinit
                0055       character*(MAX_LEN_FNAM) fnamebase
                0056
                0057       _RL fac
                0058       _RL xx_gentim2d_loc(1-olx:snx+olx,1-oly:sny+oly,nsx,nsy)
                0059       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0060       _RL LOCsumTile(nSx,nSy), LOCsumGlob
                0061
                0062 c     == external ==
                0063       integer  ilnblnk
                0064       external ilnblnk
                0065 CEOP
                0066
                0067 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0068
                0069 #ifdef ALLOW_GENTIM2D_CONTROL
                0070 C--   An example of connecting specific fields
                0071 C--   to generic time-varying 2D control arrays
                0072 cph--->>>
                0073 cph--->>> COMPILE FAILURE IS DELIBERATE
                0074 cph--->>> BE SURE WHAT YOU ARE DOING AND CUSTOMIZE <<<---
                0075 cph--->>>
                0076 C--   generic - user-defined control vars
                0077       DO iarr = 1, maxCtrlTim2D
                0078
                0079        DO bj = myByLo(myThid), myByHi(myThid)
                0080         DO bi = myBxLo(myThid), myBxHi(myThid)
                0081          DO J = 1-Oly,sNy+Oly
                0082           DO I = 1-Olx,sNx+Olx
                0083            xx_gentim2d_loc(I,J,bi,bj) = 0. _d 0
                0084           ENDDO
                0085          ENDDO
                0086         ENDDO
                0087        ENDDO
                0088 C
                0089        fnamebase = xx_gentim2d_file(iarr)
                0090        CALL CTRL_GET_GEN (
7846df7d16 Patr*0091      I      xx_gentim2d_file(iarr),
e9a88bebd8 Patr*0092      I      xx_gentim2d_startdate(1,iarr),
                0093      I      xx_gentim2d_period(iarr),
                0094      I      maskC,
                0095      O      xx_gentim2d_loc,
                0096      I      xx_gentim2d0(1-Olx,1-Oly,1,1,iarr),
                0097      I      xx_gentim2d1(1-Olx,1-Oly,1,1,iarr),
48ef8ad28f Patr*0098      I      xx_gentim2d_dummy(iarr),
e9a88bebd8 Patr*0099      I      zeroRL, zeroRL,
f569ad2a4c Gael*0100      I      wgentim2d(1-Olx,1-Oly,1,1,iarr),
e9a88bebd8 Patr*0101      I      mytime, myiter, mythid )
                0102 C
                0103       DO bj=myByLo(myThid),myByHi(myThid)
                0104        DO bi=myBxLo(myThid),myBxHi(myThid)
                0105             do j = 1,sNy
                0106               do i =  1,sNx
                0107               if (xx_gentim2d_cumsum(iarr)) then
                0108                 xx_gentim2d(i,j,bi,bj,iarr)=xx_gentim2d(i,j,bi,bj,iarr)
                0109      &            +xx_gentim2d_loc(i,j,bi,bj)
                0110               else
                0111                 xx_gentim2d(i,j,bi,bj,iarr)=xx_gentim2d_loc(i,j,bi,bj)
                0112               endif
                0113               enddo
                0114             enddo
                0115         enddo
                0116       enddo
                0117 C
                0118       if (xx_gentim2d_glosum(iarr)) then
                0119
                0120       LOCsumGlob=0. _d 0
                0121       DO bj=myByLo(myThid),myByHi(myThid)
                0122        DO bi=myBxLo(myThid),myBxHi(myThid)
                0123           LOCsumTile(bi,bj)=0. _d 0
                0124             do j = 1,sNy
                0125               do i =  1,sNx
                0126                 LOCsumTile(bi,bj)=LOCsumTile(bi,bj)+
                0127      &            maskC(i,j,1,bi,bj)*rA(i,j,bi,bj)
                0128      &            *xx_gentim2d(i,j,bi,bj,iarr)
                0129               enddo
                0130             enddo
                0131         enddo
                0132       enddo
                0133
                0134       CALL GLOBAL_SUM_TILE_RL( LOCsumTile, LOCsumGlob, myThid )
                0135
                0136        DO bj = myByLo(myThid), myByHi(myThid)
                0137         DO bi = myBxLo(myThid), myBxHi(myThid)
                0138          DO J = 1-Oly,sNy+Oly
                0139           DO I = 1-Olx,sNx+Olx
                0140              xx_gentim2d(I,J,bi,bj,iarr) =
                0141      &            LOCsumGlob/globalArea*maskC(i,j,1,bi,bj)
                0142           ENDDO
                0143          ENDDO
                0144         ENDDO
                0145        ENDDO
                0146
                0147          WRITE(msgBuf,'(A,I6,A,I6,A,1PE21.14)') ' xx_gentim2d ',
                0148      &    iarr,' : iter=', myiter, ' ; global sum = ', LOCsumGlob
                0149          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0150      &                       SQUEEZE_RIGHT, myThid )
                0151
                0152        endif
                0153
                0154        DO bj = myByLo(myThid), myByHi(myThid)
                0155         DO bi = myBxLo(myThid), myBxHi(myThid)
                0156          DO J = 1-Oly,sNy+Oly
                0157           DO I = 1-Olx,sNx+Olx
                0158            if (iarr.EQ.1) then
                0159              theta(I,J,1,bi,bj) = theta(I,J,1,bi,bj)
                0160      &                          + xx_gentim2d(I,J,bi,bj,iarr)
                0161            endif
                0162           ENDDO
                0163          ENDDO
                0164         ENDDO
                0165        ENDDO
                0166
                0167       ENDDO
                0168
                0169 #endif /* ALLOW_GENTIM2D_CONTROL */
                0170
                0171       RETURN
                0172       END