Back to home page

MITgcm
 
 

    

File indexing completed on 2023-11-05 05:10:17 UTC

view on githubraw file Latest commit 65754df4 on 2023-11-04 17:55:24 UTC
a78204c019 Mart*0001 #include "CTRL_OPTIONS.h"
                0002 
                0003 C--   File ctrl_map_genarr.F: Generic arrays control vector
                0004 C--    Contents:
                0005 C--    o CTRL_MAP_GENARR2D
                0006 C--    o CTRL_MAP_GENARR3D
                0007 
                0008 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0009 
                0010 CBOP
                0011 C     !ROUTINE: CTRL_MAP_GENARR2D
                0012 C     !INTERFACE:
                0013       SUBROUTINE CTRL_MAP_GENARR2D( fld, iarr, myThid )
                0014 
                0015 C     !DESCRIPTION: \bv
                0016 C     *=================================================================
                0017 C     | SUBROUTINE CTRL_MAP_GENARR2D
                0018 C     | Add the generic 2D-arrays of the
                0019 C     | control vector to the model state and update the tile halos.
4d72283393 Mart*0020 C     | The control vector is defined in the header file "CTRL.h".
a78204c019 Mart*0021 C     *=================================================================
                0022 C     \ev
                0023 
                0024 C     !USES:
                0025       IMPLICIT NONE
                0026 
                0027 C     == global variables ==
                0028 #include "SIZE.h"
                0029 #include "EEPARAMS.h"
                0030 #include "PARAMS.h"
                0031 #include "GRID.h"
                0032 
                0033 #include "CTRL_SIZE.h"
4d72283393 Mart*0034 #include "CTRL.h"
65754df434 Mart*0035 #include "OPTIMCYCLE.h"
a78204c019 Mart*0036 #include "CTRL_GENARR.h"
edcd27be69 Mart*0037 #include "CTRL_DUMMY.h"
a78204c019 Mart*0038 
                0039 C     !INPUT/OUTPUT PARAMETERS:
                0040       _RL     fld(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
                0041       INTEGER iarr
                0042       INTEGER myThid
                0043 
                0044 #ifdef ALLOW_GENARR2D_CONTROL
                0045 C     !FUNCTIONS:
                0046       INTEGER  ILNBLNK
                0047       EXTERNAL ILNBLNK
                0048 
                0049 C     !LOCAL VARIABLES:
                0050       INTEGER bi,bj
                0051       INTEGER i,j
                0052       INTEGER numsmo, k2
                0053       LOGICAL dowc01
                0054       LOGICAL dosmooth
                0055       LOGICAL doscaling
                0056       LOGICAL dolog10ctrl
                0057       _RL log10initval
07b7562e86 Ou W*0058       _RL ln10
a78204c019 Mart*0059       _RL xx_gen  (1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
de57a2ec4b Mart*0060       CHARACTER*(MAX_LEN_FNAM) fnamegenIn
                0061       CHARACTER*(MAX_LEN_FNAM) fnamegenOut
a78204c019 Mart*0062       CHARACTER*(MAX_LEN_FNAM) fnamebase
                0063       INTEGER ilgen
                0064       LOGICAL doglobalread
                0065       LOGICAL ladinit
                0066       _RS mask2D (1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
f9d7cbfb72 Ou W*0067       INTEGER ilDir
a78204c019 Mart*0068 CEOP
                0069 
b938a3c63b antn*0070 #ifdef ALLOW_DEBUG
                0071       IF (debugMode) CALL DEBUG_ENTER('CTRL_MAP_GENARR2D', myThid )
                0072 #endif
07b7562e86 Ou W*0073 C--   Now, read the control vector.
a78204c019 Mart*0074       doglobalread = .FALSE.
                0075       ladinit      = .FALSE.
                0076 
b4daa24319 Shre*0077 #ifndef ALLOW_TAPENADE
a78204c019 Mart*0078       CALL CTRL_ASSIGN(xx_gen, 1, zeroRL, myThid)
b4daa24319 Shre*0079 #endif
a78204c019 Mart*0080 
                0081       dosmooth=.FALSE.
                0082       dowc01  = .FALSE.
                0083       doscaling=.TRUE.
                0084       dolog10ctrl=.FALSE.
                0085       log10initval=0. _d 0
07b7562e86 Ou W*0086       ln10 = LOG(10. _d 0)
a78204c019 Mart*0087 
                0088       numsmo = 1
                0089       DO k2 = 1, maxCtrlProc
                0090         IF ( xx_genarr2d_preproc(k2,iarr).EQ.'WC01' ) THEN
                0091           dowc01 = .TRUE.
                0092           IF (xx_genarr2d_preproc_i(k2,iarr).NE.0)
                0093      &      numsmo = xx_genarr2d_preproc_i(k2,iarr)
                0094         ENDIF
                0095         IF ( (.NOT.dowc01).AND.
                0096      &       (xx_genarr2d_preproc(k2,iarr).EQ.'smooth') ) THEN
                0097           dosmooth = .TRUE.
                0098           IF (xx_genarr2d_preproc_i(k2,iarr).NE.0)
                0099      &      numsmo = xx_genarr2d_preproc_i(k2,iarr)
                0100         ENDIF
                0101         IF ( xx_genarr2d_preproc(k2,iarr).EQ.'noscaling' ) THEN
                0102           doscaling = .FALSE.
                0103         ENDIF
                0104         IF (xx_genarr2d_preproc_c(k2,iarr).EQ.'log10ctrl') THEN
07b7562e86 Ou W*0105 C             fld := log10(xx_gen)
                0106 C               with initial guess for xx_gen set to log10initval
                0107 C               passed to data.ctrl, (default = 0.0)
a78204c019 Mart*0108           dolog10ctrl=.TRUE.
                0109           log10initval = xx_genarr2d_preproc_r(k2,iarr)
                0110         ENDIF
                0111       ENDDO
                0112 
                0113       fnamebase = xx_genarr2d_file(iarr)
                0114       ilgen = ILNBLNK( fnamebase )
f9d7cbfb72 Ou W*0115 C     Find ctrlDir (w/o trailing blanks) length
                0116       ilDir = ilnblnk(ctrlDir)
de57a2ec4b Mart*0117       WRITE(fnamegenIn,'(2A,I10.10)')
f9d7cbfb72 Ou W*0118      & ctrlDir(1:ilDir)//fnamebase(1:ilgen),'.',optimcycle
de57a2ec4b Mart*0119       WRITE(fnamegenOut,'(2A,I10.10)')
f9d7cbfb72 Ou W*0120      & ctrlDir(1:ilDir)//fnamebase(1:ilgen),'.effective.',optimcycle
a78204c019 Mart*0121 
c7de4e3cb2 antn*0122       CALL READ_REC_3D_RL( xx_genarr2d_weight(iarr), ctrlprec, 1,
                0123      &          wgenarr2d(1-OLx,1-OLy,1,1,iarr), 1, 1, myThid )
a78204c019 Mart*0124 
                0125 #ifdef ALLOW_AUTODIFF
                0126       CALL ACTIVE_READ_XY( fnamegenIn, xx_gen, 1, doglobalread,
                0127      &     ladinit, optimcycle, myThid, xx_genarr2d_dummy(iarr) )
                0128 #else
                0129       CALL READ_REC_XY_RL( fnamegenIn, xx_gen, 1, 1, myThid)
                0130 #endif
                0131 
                0132 C --- Get appropriate mask for ctrl variable
                0133       CALL CTRL_GET_MASK2D(xx_genarr2d_file(iarr), mask2D, myThid)
                0134 
                0135 C --- Do any smoothing
                0136 #ifdef ALLOW_SMOOTH
                0137       IF (useSMOOTH) THEN
                0138        IF (dowc01) CALL SMOOTH_CORREL2D(xx_gen,mask2D,numsmo,myThid)
                0139        IF (dosmooth) CALL SMOOTH2D(xx_gen,mask2D,numsmo,myThid)
                0140       ENDIF
                0141 #endif
                0142 
                0143       DO bj=myByLo(myThid), myByHi(myThid)
                0144        DO bi=myBxLo(myThid), myBxHi(myThid)
07b7562e86 Ou W*0145         IF (doscaling) THEN
                0146          DO j = 1,sNy
                0147           DO i = 1,sNx
                0148 C scale param adjustment
                0149            IF ( wgenarr2d(i,j,bi,bj,iarr).GT.0. ) THEN
a78204c019 Mart*0150             xx_gen(i,j,bi,bj) = xx_gen(i,j,bi,bj)
07b7562e86 Ou W*0151      &               / SQRT( wgenarr2d(i,j,bi,bj,iarr) )
a78204c019 Mart*0152             IF (dolog10ctrl) THEN
                0153              xx_gen(i,j,bi,bj) = xx_gen(i,j,bi,bj) + log10initval
07b7562e86 Ou W*0154 c            xx_gen(i,j,bi,bj) = 10.0 ** xx_gen(i,j,bi,bj)
                0155 C     this is faster, especially if log(10) has been evaluated before
                0156 c            xx_gen(i,j,bi,bj) = EXP(LOG(10.0) * xx_gen(i,j,bi,bj))
                0157              xx_gen(i,j,bi,bj) = EXP(ln10 * xx_gen(i,j,bi,bj))
                0158             ENDIF ! dolog10ctrls
                0159            ELSE
                0160             xx_gen(i,j,bi,bj) = 0. _d 0
                0161            ENDIF
                0162           ENDDO
a78204c019 Mart*0163          ENDDO
07b7562e86 Ou W*0164         ENDIF ! doscaling
                0165 C add to model parameter
                0166 C or in case of log10ctrl, fld = 10^(xx_gen)
                0167         IF (dolog10ctrl) THEN
                0168          DO j = 1,sNy
                0169           DO i = 1,sNx
                0170            fld(i,j,bi,bj) = xx_gen(i,j,bi,bj)*mask2D(i,j,bi,bj)
                0171           ENDDO
                0172          ENDDO
                0173         ELSE
                0174          DO j = 1,sNy
                0175           DO i = 1,sNx
                0176            fld(i,j,bi,bj) = fld(i,j,bi,bj)
                0177      &           + xx_gen(i,j,bi,bj)*mask2D(i,j,bi,bj)
                0178           ENDDO
                0179          ENDDO
                0180         ENDIF ! dolog10ctrls
a78204c019 Mart*0181        ENDDO
                0182       ENDDO
                0183 
07b7562e86 Ou W*0184 C avoid param out of [boundsVec(1) boundsVec(4)]
a78204c019 Mart*0185       CALL CTRL_BOUND_2D(fld,mask2D,xx_genarr2d_bounds(1,iarr),myThid)
                0186 
                0187       CALL EXCH_XY_RL( fld, myThid )
                0188 
b4daa24319 Shre*0189 #ifdef ALLOW_TAPENADE
                0190 C$AD DO-NOT-DIFF
                0191 #endif
c7de4e3cb2 antn*0192       CALL WRITE_REC_3D_RL( fnamegenOut, ctrlprec, 1,
                0193      &                      fld, 1, optimcycle, myThid )
b4daa24319 Shre*0194 #ifdef ALLOW_TAPENADE
                0195 C$AD END-DO-NOT-DIFF
                0196 #endif
a78204c019 Mart*0197 
b938a3c63b antn*0198 #ifdef ALLOW_DEBUG
                0199       IF (debugMode) CALL DEBUG_LEAVE('CTRL_MAP_GENARR2D', myThid )
                0200 #endif
a78204c019 Mart*0201 #endif /* ALLOW_GENARR2D_CONTROL */
                0202 
                0203       RETURN
                0204       END
                0205 
                0206 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0207 
                0208 CBOP
                0209 C     !ROUTINE: CTRL_MAP_GENARR3D
                0210 C     !INTERFACE:
                0211       SUBROUTINE CTRL_MAP_GENARR3D( fld, iarr, myThid )
                0212 
                0213 C     !DESCRIPTION: \bv
                0214 C     *=================================================================
                0215 C     | SUBROUTINE CTRL_MAP_GENARR3D
                0216 C     | Add the generic 3D-arrays of the
                0217 C     | control vector to the model state and update the tile halos.
4d72283393 Mart*0218 C     | The control vector is defined in the header file "CTRL.h".
a78204c019 Mart*0219 C     *=================================================================
                0220 C     \ev
                0221 
                0222 C     !USES:
                0223       IMPLICIT NONE
                0224 
                0225 C     == global variables ==
                0226 #include "SIZE.h"
                0227 #include "EEPARAMS.h"
                0228 #include "PARAMS.h"
                0229 #include "GRID.h"
                0230 
                0231 #include "CTRL_SIZE.h"
4d72283393 Mart*0232 #include "CTRL.h"
65754df434 Mart*0233 #include "OPTIMCYCLE.h"
a78204c019 Mart*0234 #include "CTRL_GENARR.h"
edcd27be69 Mart*0235 #include "CTRL_DUMMY.h"
a78204c019 Mart*0236 
                0237 C     !INPUT/OUTPUT PARAMETERS:
                0238       _RL     fld(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr,nSx,nSy)
                0239       INTEGER iarr
                0240       INTEGER myThid
                0241 
                0242 #ifdef ALLOW_OPENAD
                0243       STOP 'ABNORMAL END: CTRL_MAP_GENARR3D is empty'
                0244 #else /* ALLOW_OPENAD */
                0245 #ifdef ALLOW_GENARR3D_CONTROL
                0246 C     !FUNCTIONS:
                0247       INTEGER  ILNBLNK
                0248       EXTERNAL ILNBLNK
                0249 
                0250 C     !LOCAL VARIABLES:
                0251       INTEGER bi,bj
                0252       INTEGER i,j,k
                0253       INTEGER numsmo,k2
                0254       LOGICAL dowc01
                0255       LOGICAL dosmooth
                0256       LOGICAL doscaling
                0257       LOGICAL dolog10ctrl
                0258       _RL log10initval
                0259       _RL ln10
                0260       _RL xx_gen(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr,nSx,nSy)
de57a2ec4b Mart*0261       CHARACTER*(MAX_LEN_FNAM) fnamegenIn
                0262       CHARACTER*(MAX_LEN_FNAM) fnamegenOut
a78204c019 Mart*0263       CHARACTER*(MAX_LEN_FNAM) fnamebase
                0264       INTEGER ilgen
                0265       LOGICAL doglobalread
                0266       LOGICAL ladinit
                0267       _RS mask3D(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr,nSx,nSy)
f9d7cbfb72 Ou W*0268       INTEGER ilDir
a78204c019 Mart*0269 CEOP
                0270 
b938a3c63b antn*0271 #ifdef ALLOW_DEBUG
                0272       IF (debugMode) CALL DEBUG_ENTER('CTRL_MAP_GENARR3D', myThid )
                0273 #endif
07b7562e86 Ou W*0274 C--   Now, read the control vector.
a78204c019 Mart*0275       doglobalread = .FALSE.
                0276       ladinit      = .FALSE.
b4daa24319 Shre*0277 #ifndef ALLOW_TAPENADE
a78204c019 Mart*0278       CALL CTRL_ASSIGN(xx_gen, Nr, zeroRL, myThid)
b4daa24319 Shre*0279 #endif
a78204c019 Mart*0280       dosmooth=.FALSE.
                0281       dowc01  = .FALSE.
                0282       doscaling=.TRUE.
                0283       dolog10ctrl=.FALSE.
                0284       log10initval=0. _d 0
07b7562e86 Ou W*0285       ln10 = LOG(10. _d 0)
a78204c019 Mart*0286 
                0287       numsmo = 1
                0288       DO k2 = 1, maxCtrlProc
                0289         IF ( xx_genarr3d_preproc(k2,iarr).EQ.'WC01' ) THEN
                0290           dowc01 = .TRUE.
                0291           IF (xx_genarr3d_preproc_i(k2,iarr).NE.0)
                0292      &      numsmo = xx_genarr3d_preproc_i(k2,iarr)
                0293         ENDIF
                0294         IF ( (.NOT.dowc01).AND.
                0295      &       (xx_genarr3d_preproc(k2,iarr).EQ.'smooth') ) THEN
                0296           dosmooth = .TRUE.
                0297           IF (xx_genarr3d_preproc_i(k2,iarr).NE.0)
                0298      &      numsmo = xx_genarr3d_preproc_i(k2,iarr)
                0299         ENDIF
                0300         IF (xx_genarr3d_preproc(k2,iarr).EQ.'noscaling') THEN
                0301           doscaling = .FALSE.
                0302         ENDIF
                0303         IF (xx_genarr3d_preproc_c(k2,iarr).EQ.'log10ctrl') THEN
07b7562e86 Ou W*0304 C             fld := log10(xx_gen)
                0305 C               with initial guess for xx_gen set to log10initval
                0306 C               passed to data.ctrl, (default = 0.0)
a78204c019 Mart*0307           dolog10ctrl=.TRUE.
                0308           log10initval = xx_genarr3d_preproc_r(k2,iarr)
                0309         ENDIF
                0310       ENDDO
                0311 
                0312       fnamebase = xx_genarr3d_file(iarr)
                0313       ilgen = ILNBLNK( fnamebase )
f9d7cbfb72 Ou W*0314 C     Find ctrlDir (w/o trailing blanks) length
                0315       ilDir = ilnblnk(ctrlDir)
de57a2ec4b Mart*0316       WRITE(fnamegenIn,'(2a,i10.10)')
f9d7cbfb72 Ou W*0317      & ctrlDir(1:ilDir)//fnamebase(1:ilgen),'.',optimcycle
de57a2ec4b Mart*0318       WRITE(fnamegenOut,'(2a,i10.10)')
f9d7cbfb72 Ou W*0319      & ctrlDir(1:ilDir)//fnamebase(1:ilgen),'.effective.',optimcycle
a78204c019 Mart*0320 
c7de4e3cb2 antn*0321       CALL READ_REC_3D_RL( xx_genarr3d_weight(iarr), ctrlprec, Nr,
                0322      &          wgenarr3d(1-OLx,1-OLy,1,1,1,iarr), 1, 1, myThid )
a78204c019 Mart*0323 
                0324 #ifdef ALLOW_AUTODIFF
                0325       CALL ACTIVE_READ_XYZ( fnamegenIn, xx_gen, 1, doglobalread,
                0326      & ladinit, optimcycle, myThid, xx_genarr3d_dummy(iarr) )
                0327 #else
                0328       CALL READ_REC_XYZ_RL( fnamegenIn, xx_gen, 1, 1, myThid)
                0329 #endif
                0330 
                0331 C --- Get appropriate mask for ctrl variable
                0332       CALL CTRL_GET_MASK3D(xx_genarr3d_file(iarr), mask3D, myThid)
                0333 
                0334 C --- Do any smoothing
                0335 #ifdef ALLOW_SMOOTH
                0336       IF (useSMOOTH) THEN
                0337        IF (dowc01) CALL SMOOTH_CORREL3D( xx_gen, numsmo, myThid )
                0338        IF (dosmooth) CALL SMOOTH3D( xx_gen, numsmo, myThid )
                0339       ENDIF
                0340 #endif
                0341 
                0342       DO bj=myByLo(myThid), myByHi(myThid)
                0343        DO bi=myBxLo(myThid), myBxHi(myThid)
                0344         IF (doscaling) THEN
07b7562e86 Ou W*0345 C     scale param adjustment
a78204c019 Mart*0346          DO k = 1,Nr
                0347           DO j = 1,sNy
                0348            DO i = 1,sNx
                0349             IF ( wgenarr3d(i,j,k,bi,bj,iarr).GT.0. ) THEN
07b7562e86 Ou W*0350              xx_gen(i,j,k,bi,bj) = xx_gen(i,j,k,bi,bj)
                0351      &                / SQRT( wgenarr3d(i,j,k,bi,bj,iarr) )
                0352              IF (dolog10ctrl) THEN
                0353               xx_gen(i,j,k,bi,bj) = xx_gen(i,j,k,bi,bj) + log10initval
                0354 c             xx_gen(i,j,k,bi,bj) = 10.0 ** xx_gen(i,j,k,bi,bj)
                0355 C     this is faster, especially if log(10) has been evaluated before
                0356 c             xx_gen(i,j,k,bi,bj) = EXP(LOG(10.0) * xx_gen(i,j,k,bi,bj))
                0357               xx_gen(i,j,k,bi,bj) = EXP(ln10 * xx_gen(i,j,k,bi,bj))
                0358              ENDIF
                0359             ELSE
                0360              xx_gen(i,j,k,bi,bj) = 0. _d 0
a78204c019 Mart*0361             ENDIF
                0362            ENDDO
                0363           ENDDO
                0364          ENDDO
07b7562e86 Ou W*0365 C     doscaling
a78204c019 Mart*0366         ENDIF
07b7562e86 Ou W*0367 C     add to model parameter
                0368 C     or in case of log10ctrl, fld = 10^(xx_gen)
                0369         IF ( dolog10ctrl ) THEN
a78204c019 Mart*0370          DO k = 1,Nr
                0371           DO j = 1,sNy
                0372            DO i = 1,sNx
07b7562e86 Ou W*0373             fld(i,j,k,bi,bj) = xx_gen(i,j,k,bi,bj)*mask3D(i,j,k,bi,bj)
a78204c019 Mart*0374            ENDDO
                0375           ENDDO
                0376          ENDDO
                0377         ELSE
                0378          DO k = 1,Nr
                0379           DO j = 1,sNy
                0380            DO i = 1,sNx
07b7562e86 Ou W*0381             fld(i,j,k,bi,bj) = fld(i,j,k,bi,bj)
                0382      &           + xx_gen(i,j,k,bi,bj)*mask3D(i,j,k,bi,bj)
a78204c019 Mart*0383            ENDDO
                0384           ENDDO
                0385          ENDDO
                0386         ENDIF
07b7562e86 Ou W*0387 C     end bi/bj-loops
a78204c019 Mart*0388        ENDDO
                0389       ENDDO
                0390 
07b7562e86 Ou W*0391 C avoid param out of [boundsVec(1) boundsVec(4)]
a78204c019 Mart*0392       CALL CTRL_BOUND_3D(fld,mask3D,xx_genarr3d_bounds(1,iarr),myThid)
                0393 
                0394 C The tile exchange for xx_uvel and xx_vvel will be
                0395 C  done in CTRL_MAP_INI_GENARR.F when both
                0396 C  xx_uvel and xx_vvel are read in.
                0397       IF (xx_genarr3d_file(iarr)(1:7).NE.'xx_uvel'.AND.
                0398      &    xx_genarr3d_file(iarr)(1:7).NE.'xx_vvel')
                0399      &    CALL EXCH_XYZ_RL( fld, myThid )
                0400 
b4daa24319 Shre*0401 #ifdef ALLOW_TAPENADE
                0402 C$AD DO-NOT-DIFF
                0403 #endif
c7de4e3cb2 antn*0404       CALL WRITE_REC_3D_RL( fnamegenOut, ctrlprec, Nr,
                0405      &                      fld, 1, optimcycle, myThid )
b4daa24319 Shre*0406 #ifdef ALLOW_TAPENADE
                0407 C$AD END-DO-NOT-DIFF
                0408 #endif
a78204c019 Mart*0409 
b938a3c63b antn*0410 #ifdef ALLOW_DEBUG
                0411       IF (debugMode) CALL DEBUG_LEAVE('CTRL_MAP_GENARR3D', myThid )
                0412 #endif
a78204c019 Mart*0413 #endif /* ALLOW_GENARR3D_CONTROL */
                0414 #endif /* ALLOW_OPENAD */
                0415 
                0416       RETURN
                0417       END
[ Source navigation ] [ Diff markup ] [ Identifier search ] [ general search ]

This page was automatically generated from https://github.com/MITgcm/MITgcm by the 2.2.1-MITgcm-0.1 LXR engine.

The LXR team
Valid CSS 2.1! Valid HTML 4.01!