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