tutorial_global_oce_optim/code_oad/ctrl_map_ini_genarr.F

2e7aec9951 dngo*0001 #include "CTRL_OPTIONS.h"
                0002
                0003 CBOP
                0004 C     !ROUTINE: CTRL_MAP_INI_GENARR
                0005 C     !INTERFACE:
                0006       SUBROUTINE CTRL_MAP_INI_GENARR( myThid )
                0007
                0008 C     !DESCRIPTION: \bv
                0009 C     *=================================================================
                0010 C     | SUBROUTINE CTRL_MAP_INI_GENARR
                0011 C     | Add the generic arrays of the
                0012 C     | control vector to the model state and update the tile halos.
4d72283393 Mart*0013 C     | The control vector is defined in the header file "CTRL.h".
2e7aec9951 dngo*0014 C     *=================================================================
                0015 C     | local version for OpenAD exp. tutorial_global_oce_optim
                0016 C     *=================================================================
                0017 C     \ev
                0018
                0019 C     !USES:
                0020       IMPLICIT NONE
                0021
                0022 C     == global variables ==
                0023 #include "SIZE.h"
                0024 #include "EEPARAMS.h"
                0025 #include "PARAMS.h"
                0026 #include "GRID.h"
                0027 CML#include "DYNVARS.h"
                0028 #include "FFIELDS.h"
                0029 #include "CTRL_SIZE.h"
4d72283393 Mart*0030 #include "CTRL.h"
2e7aec9951 dngo*0031 #include "CTRL_GENARR.h"
edcd27be69 Mart*0032 #include "CTRL_DUMMY.h"
65754df434 Mart*0033 #include "OPTIMCYCLE.h"
2e7aec9951 dngo*0034
                0035 C     !INPUT/OUTPUT PARAMETERS:
                0036 C     == routine arguments ==
                0037       INTEGER myThid
                0038
                0039 C     !FUNCTIONS:
                0040       INTEGER  ILNBLNk
                0041       EXTERNAL ILNBLNK
                0042
                0043 C     !LOCAL VARIABLES:
                0044 C     == local variables ==
                0045       INTEGER bi,bj
                0046       INTEGER i,j
                0047       INTEGER il
                0048       INTEGER iarr
                0049
                0050       LOGICAL doglobalread
                0051       LOGICAL ladinit
                0052       CHARACTER*(MAX_LEN_FNAM) fnamebase
de57a2ec4b Mart*0053       CHARACTER*(MAX_LEN_FNAM) fnamegeneric
2e7aec9951 dngo*0054       _RL     fac
                0055 #ifdef ALLOW_GENARR2D_CONTROL
                0056       _RL     tmpfld2d(1-OLx:sNx+OLx,1-OLy:sNy+OLy,   nSx,nSy)
                0057 #endif
                0058 #ifdef ALLOW_GENARR3D_CONTROL
                0059       INTEGER k
                0060       _RL     tmpfld3d(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr,nSx,nSy)
                0061 #endif
                0062 CEOP
                0063
                0064       doglobalread = .FALSE.
                0065       ladinit      = .FALSE.
                0066       fac = 1. _d 0
                0067
                0068 #ifdef ALLOW_GENARR2D_CONTROL
                0069 C--   An example of connecting specific fields
                0070 C--   to 3 generic 2D control arrays
                0071 cc--->>>
                0072 cc--->>> COMPILE FAILURE IS DELIBERATE
                0073 cc--->>> BE SURE WHAT YOU ARE DOING AND CUSTOMIZE <<<---
                0074 cc--->>>
                0075 C--   generic - user-defined control vars
                0076       DO iarr = 1, maxCtrlArr2D
                0077
                0078 C     The control variables in this experiment is the mean heat flux. As
                0079 C     is it constant in time , we can specify it here and add it to qnet
                0080 C     at the beginning of the integration.
                0081        DO bj=myByLo(myThid), myByHi(myThid)
                0082         DO bi=myBxLo(myThid), myBxHi(myThid)
                0083          DO j = 1,sNy
                0084           DO i = 1,sNx
                0085            tmpfld2d(i,j,bi,bj) = 0. _d 0
                0086           ENDDO
                0087          ENDDO
                0088         ENDDO
                0089        ENDDO
                0090        fnamebase = xx_genarr2d_file(iarr)
                0091        il=ILNBLNK( fnamebase )
de57a2ec4b Mart*0092        WRITE(fnamegeneric,'(2A,I10.10)')
2e7aec9951 dngo*0093      &     fnamebase(1:il),'.',optimcycle
                0094        CALL ACTIVE_READ_XY ( fnamegeneric, tmpfld2d, 1,
                0095      &                      doglobalread, ladinit, optimcycle,
                0096      &                      myThid, xx_genarr2d_dummy(iarr) )
                0097        IF ( iarr .EQ. 1 ) THEN
                0098         DO bj=myByLo(myThid), myByHi(myThid)
                0099          DO bi=myBxLo(myThid), myBxHi(myThid)
                0100           DO j = 1,sNy
                0101            DO i = 1,sNx
                0102             Qnetm(i,j,bi,bj) = Qnetm(i,j,bi,bj)
                0103      &           + fac*tmpfld2d(i,j,bi,bj)
                0104            ENDDO
                0105           ENDDO
                0106          ENDDO
                0107         ENDDO
                0108        ENDIF
                0109 C--   end iarr loop
                0110       ENDDO
                0111       _EXCH_XY_RS( Qnetm, myThid )
                0112
                0113 #endif /* ALLOW_GENARR2D_CONTROL */
                0114
                0115 #ifdef ALLOW_GENARR3D_CONTROL
                0116 C--   An example of connecting specific fields
                0117 C--   to 3 generic 3D control arrays
                0118 cc--->>>
                0119 cc--->>> COMPILE FAILURE IS DELIBERATE
                0120 cc--->>> BE SURE WHAT YOU ARE DOING AND CUSTOMIZE <<<---
                0121 cc--->>>
                0122 cc
                0123
                0124 C--   generic - user-defined control vars
                0125       DO iarr = 1, maxCtrlArr3D
                0126
                0127        DO bj=myByLo(myThid), myByHi(myThid)
                0128         DO bi=myBxLo(myThid), myBxHi(myThid)
                0129          DO k = 1,Nr
                0130           DO j = 1,sNy
                0131            DO i = 1,sNx
                0132             tmpfld3d(i,j,k,bi,bj) = 0. _d 0
                0133            ENDDO
                0134           ENDDO
                0135          ENDDO
                0136         ENDDO
                0137        ENDDO
                0138        fnamebase = xx_genarr3d_file(iarr)
                0139        il=ILNBLNK( fnamebase )
de57a2ec4b Mart*0140        WRITE(fnamegeneric,'(2A,I10.10)')
2e7aec9951 dngo*0141      &     fnamebase(1:il),'.',optimcycle
                0142        CALL ACTIVE_READ_XYZ( fnamegeneric, tmpfld3d, 1,
                0143      &                       doglobalread, ladinit, optimcycle,
                0144      &                       myThid, xx_genarr3d_dummy(iarr) )
                0145        IF ( iarr .EQ. 1 ) THEN
                0146 CML        DO bj=myByLo(myThid), myByHi(myThid)
                0147 CML         DO bi=myBxLo(myThid), myBxHi(myThid)
                0148 CML          DO k = 1,Nr
                0149 CML           DO j = 1,sNy
                0150 CML            DO i = 1,sNx
                0151 CML             theta(i,j,k,bi,bj) = theta(i,j,k,bi,bj)
                0152 CML     &         + fac*tmpfld3d(i,j,k,bi,bj)
                0153 CML            ENDDO
                0154 CML           ENDDO
                0155 CML          ENDDO
                0156 CML         ENDDO
                0157 CML        ENDDO
                0158 CML        CALL EXCH_3D_RL( theta, Nr, myThid )
                0159       ENDIF
                0160
                0161 C--   end iarr loop
                0162       ENDDO
                0163
                0164 #endif /* ALLOW_GENARR3D_CONTROL */
                0165
                0166       RETURN
                0167       END