** Warning **

Issuing rollback() due to DESTROY without explicit disconnect() of DBD::mysql::db handle dbname=MITgcm at /usr/local/share/lxr/lib/LXR/Common.pm line 1224.

Last-Modified: Sat, 31 Oct 2025 05:09:10 GMT Content-Type: text/html; charset=utf-8 MITgcm/MITgcm/pkg/ctrl/ctrl_init_fixed.F
Back to home page

MITgcm
 
 

    

File indexing completed on 2024-07-17 05:10:38 UTC

view on githubraw file Latest commit acacc28f on 2024-07-17 03:59:01 UTC
5cf4364659 Mart*0001 #include "CTRL_OPTIONS.h"
                0002 
                0003 CBOP
                0004 C     !ROUTINE: CTRL_INIT_FIXED
                0005 C     !INTERFACE:
                0006       SUBROUTINE CTRL_INIT_FIXED( myThid )
                0007 
                0008 C     !DESCRIPTION: \bv
                0009 C     *=================================================================
                0010 C     | SUBROUTINE CTRL_INIT_FIXED
                0011 C     | o Define the vector of control variables
                0012 C     *=================================================================
                0013 C     \ev
                0014 
                0015 C     !USES:
                0016       IMPLICIT NONE
                0017 
                0018 C     === Global variables ===
                0019 #include "EEPARAMS.h"
                0020 #include "SIZE.h"
                0021 #include "PARAMS.h"
                0022 #include "GRID.h"
                0023 #ifdef ALLOW_CTRL
                0024 # include "CTRL_SIZE.h"
                0025 # include "CTRL.h"
                0026 # include "CTRL_GENARR.h"
                0027 # include "CTRL_OBCS.h"
                0028 #endif
                0029 #ifdef ALLOW_CAL
                0030 # include "cal.h"
                0031 #endif
                0032 #ifdef ALLOW_DIC_CONTROL
                0033 # include "DIC_CTRL.h"
                0034 #endif
                0035 
                0036 C     !INPUT/OUTPUT PARAMETERS:
                0037 C     myThid     :: my Thread Id number
                0038       INTEGER myThid
                0039 
                0040 C     !FUNCTIONS:
                0041 #ifdef ALLOW_GENTIM2D_CONTROL
                0042       INTEGER  ILNBLNK
                0043       EXTERNAL ILNBLNK
                0044 #endif
                0045 #ifdef ALLOW_OBCS_CONTROL_MODES
                0046       INTEGER  MDS_RECLEN
                0047       EXTERNAL MDS_RECLEN
                0048 #endif
                0049 
                0050 C     !LOCAL VARIABLES:
                0051 C     msgBuf     :: Informational/error message buffer
                0052       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0053       INTEGER bi, bj
                0054       INTEGER i, j, k
                0055       INTEGER ivar, iarr
acacc28f7f Jean*0056       LOGICAL costFinalExist
5cf4364659 Mart*0057       _RL dummy
                0058       _RL loctmp3d (1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr,nSx,nSy)
                0059 
                0060 #if ( defined ALLOW_GENTIM2D_CONTROL || \
                0061       defined ALLOW_GENARR2D_CONTROL || \
                0062       defined ALLOW_GENARR3D_CONTROL )
                0063       CHARACTER*(1) ncvargrdtmp
                0064 #endif
                0065 #ifdef ALLOW_GENTIM2D_CONTROL
                0066       CHARACTER*(MAX_LEN_FNAM) fnamegen
                0067       INTEGER ilgen, k2, diffrecFull, endrecFull
                0068       INTEGER diffrec, startrec, endrec
                0069 #elif ( defined ALLOW_OBCS_CONTROL )
                0070       INTEGER diffrec, startrec, endrec
                0071 #endif
                0072 
                0073 #ifdef ALLOW_OBCS_CONTROL_MODES
                0074       INTEGER  length_of_rec, dUnit
                0075 #endif
                0076 CEOP
                0077 
                0078 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0079 
                0080 C--     Set default values.
                0081       DO ivar = 1,maxcvars
                0082        ncvarindex(ivar) = -1
                0083        ncvarrecs(ivar)  =  0
                0084        ncvarxmax(ivar)  =  0
                0085        ncvarymax(ivar)  =  0
                0086        ncvarnrmax(ivar) =  0
                0087        ncvargrd(ivar)   = '?'
                0088        ncvartype(ivar)  = '?'
                0089        ncvarfname(ivar) = ' '
                0090       ENDDO
                0091 
                0092 C     Set unit weight to 1
                0093       DO bj=1,nSy
                0094        DO bi=1,nSx
                0095         DO k=1,Nr
                0096           wunit(k,bi,bj) = 1. _d 0
                0097           DO j=1-OLy,sNy+OLy
                0098            DO i=1-OLx,sNx+OLx
                0099              loctmp3d(i,j,k,bi,bj) = 1. _d 0
                0100            ENDDO
                0101           ENDDO
                0102         ENDDO
                0103        ENDDO
                0104       ENDDO
                0105 
                0106 #ifdef ALLOW_AUTODIFF
                0107       CALL active_write_xyz( 'wunit', loctmp3d, 1, 0, myThid, dummy)
                0108 #else
                0109       CALL WRITE_REC_XYZ_RL( 'wunit', loctmp3d, 1, 1, myThid )
                0110 #endif
                0111 
                0112 #ifdef CTRL_DO_PACK_UNPACK_ONLY
acacc28f7f Jean*0113       costFinalExist = .FALSE.
                0114 #else /* CTRL_DO_PACK_UNPACK_ONLY */
5cf4364659 Mart*0115 c     _BEGIN_MASTER( myThid )
acacc28f7f Jean*0116       INQUIRE( FILE='costfinal', EXIST=costFinalExist )
5cf4364659 Mart*0117 c     _END_MASTER( myThid )
acacc28f7f Jean*0118 #endif /* CTRL_DO_PACK_UNPACK_ONLY */
5cf4364659 Mart*0119 
                0120       _BARRIER
                0121 
                0122       ivar = 0
                0123 C--   ===========================
                0124 C--   Open boundary contributions.
                0125 C--   ===========================
                0126 
                0127 C----------------------------------------------------------------------
                0128 
                0129 #ifdef ALLOW_OBCSN_CONTROL
                0130 C--   Northern obc.
                0131       CALL ctrl_init_rec ( xx_obcsn_file,
                0132      I     xx_obcsnstartdate1, xx_obcsnstartdate2, xx_obcsnperiod, 4,
                0133      O     xx_obcsnstartdate, diffrec, startrec, endrec,
                0134      I     myThid )
                0135       ivar = ivar + 1
                0136       iarr = 1
                0137       CALL ctrl_init_ctrlvar (
                0138      I     xx_obcsn_file, ivar, iarr, diffrec, startrec, endrec,
acacc28f7f Jean*0139      I     sNx, 1, Nr, 'm', 'SecXZ', costFinalExist, myThid )
5cf4364659 Mart*0140 #endif /* ALLOW_OBCSN_CONTROL */
                0141 
                0142 C----------------------------------------------------------------------
                0143 
                0144 #ifdef ALLOW_OBCSS_CONTROL
                0145 C--   Southern obc.
                0146       CALL ctrl_init_rec ( xx_obcss_file,
                0147      I     xx_obcssstartdate1, xx_obcssstartdate2, xx_obcssperiod, 4,
                0148      O     xx_obcssstartdate, diffrec, startrec, endrec,
                0149      I     myThid )
                0150       ivar = ivar+1
                0151       iarr = 2
                0152       CALL ctrl_init_ctrlvar (
                0153      I     xx_obcss_file, ivar, iarr, diffrec, startrec, endrec,
acacc28f7f Jean*0154      I     sNx, 1, Nr, 'm', 'SecXZ', costFinalExist, myThid )
5cf4364659 Mart*0155 #endif /* ALLOW_OBCSS_CONTROL */
                0156 
                0157 C----------------------------------------------------------------------
                0158 
                0159 #ifdef ALLOW_OBCSW_CONTROL
                0160 C--   Western obc.
                0161       CALL ctrl_init_rec ( xx_obcsw_file,
                0162      I     xx_obcswstartdate1, xx_obcswstartdate2, xx_obcswperiod, 4,
                0163      O     xx_obcswstartdate, diffrec, startrec, endrec,
                0164      I     myThid )
                0165       ivar = ivar+1
                0166       iarr = 4
                0167       CALL ctrl_init_ctrlvar (
                0168      I     xx_obcsw_file, ivar, iarr, diffrec, startrec, endrec,
acacc28f7f Jean*0169      I     1, sNy, Nr, 'm', 'SecYZ', costFinalExist, myThid )
5cf4364659 Mart*0170 #endif  /* ALLOW_OBCSW_CONTROL */
                0171 
                0172 C----------------------------------------------------------------------
                0173 
                0174 #ifdef ALLOW_OBCSE_CONTROL
                0175 C--   Eastern obc.
                0176       CALL ctrl_init_rec ( xx_obcse_file,
                0177      I     xx_obcsestartdate1, xx_obcsestartdate2, xx_obcseperiod, 4,
                0178      O     xx_obcsestartdate, diffrec, startrec, endrec,
                0179      I     myThid )
                0180       ivar = ivar+1
                0181       iarr = 3
                0182       CALL ctrl_init_ctrlvar (
                0183      I     xx_obcse_file, ivar, iarr, diffrec, startrec, endrec,
acacc28f7f Jean*0184      I     1, sNy, Nr, 'm', 'SecYZ', costFinalExist, myThid )
5cf4364659 Mart*0185 #endif /* ALLOW_OBCSE_CONTROL */
                0186 
                0187 C----------------------------------------------------------------------
                0188 
                0189 #ifdef ALLOW_OBCS_CONTROL_MODES
                0190 Cih  Get matrices for reconstruction from barotropic-barclinic modes
                0191 CMM  To use modes now hardcoded with ECCO_CPPOPTION.  Would be good to have
                0192 C     run-time option and also define filename=baro_invmodes.bin
                0193         CALL MDSFINDUNIT( dUnit, myThid )
                0194         length_of_rec = MDS_RECLEN( 64, Nr*Nr, myThid )
                0195         OPEN( dUnit, FILE='baro_invmodes.bin', STATUS='old',
                0196      &         ACCESS='direct', RECL=length_of_rec )
                0197         DO j = 1,Nr
                0198            READ(dUnit,rec=j) ((modesv(k,i,j), k=1,Nr), i=1,Nr)
                0199         ENDDO
                0200         CLOSE( dUnit )
                0201 CMM  double precision modesv is size [NR,NR,NR]
                0202 C     dim one is z-space
                0203 C     dim two is mode space
                0204 C     dim three is the total depth for which this set of modes applies
                0205 C     so for example modesv(:,2,nr) will be the second mode
                0206 C     in z-space for the full model depth
                0207 C    The modes are to be orthogonal when weighted by dz.
                0208 C     i.e. if f_i(z) = mode i, sum_j(f_i(z_j)*f_j(z_j)*dz_j = delta_ij
                0209 C    first mode should also be constant in depth...barotropic
                0210 C    For a matlab code example how to construct the orthonormal modes,
                0211 C     which are ideally the solution of planetary vertical mode equation
                0212 C     using model mean dRho/dz, see
                0213 C     MITgcm/verification/obcs_ctrl/input/gendata.m
                0214 C    This code is compatible with partial cells
acacc28f7f Jean*0215 #endif /* ALLOW_OBCS_CONTROL_MODES */
5cf4364659 Mart*0216 
                0217 C----------------------------------------------------------------------
                0218 
                0219 #ifdef ALLOW_GENARR2D_CONTROL
                0220       DO iarr = 1, maxCtrlArr2D
                0221        ncvargrdtmp='c'
                0222 # ifdef ALLOW_SHELFICE
                0223 C      Under iceshelf, use maskSHI for these
                0224        IF ((xx_genarr2d_file(iarr)(1:11).EQ.'xx_shicoeff').OR.
                0225      &     (xx_genarr2d_file(iarr)(1:11).EQ.'xx_shicdrag')) THEN
                0226          ncvargrdtmp='i'
                0227        ENDIF
                0228 # endif
                0229 
                0230 #ifndef ALLOW_OPENAD
                0231        IF (xx_genarr2d_weight(iarr).NE.' ') THEN
                0232 #endif
                0233         ivar = ivar+1
                0234         CALL ctrl_init_ctrlvar (
                0235      I       xx_genarr2d_file(iarr),
                0236      I       ivar, iarr, 1, 1, 1,
acacc28f7f Jean*0237      I       sNx, sNy, 1, ncvargrdtmp, 'Arr2D', costFinalExist,
5cf4364659 Mart*0238      I       myThid )
                0239 #ifndef ALLOW_OPENAD
                0240        ENDIF
                0241 #endif
                0242       ENDDO
                0243 #endif /* ALLOW_GENARR2D_CONTROL */
                0244 
                0245 C----------------------------------------------------------------------
                0246 
                0247 #ifdef ALLOW_GENARR3D_CONTROL
                0248       DO iarr = 1, maxCtrlArr3D
                0249        ncvargrdtmp='c'
                0250 #ifndef ALLOW_OPENAD
                0251        IF (xx_genarr3d_weight(iarr).NE.' ') THEN
                0252 #endif
                0253         ivar = ivar+1
                0254         CALL ctrl_init_ctrlvar (
                0255      I       xx_genarr3d_file(iarr),
                0256      I       ivar, iarr, 1, 1, 1,
acacc28f7f Jean*0257      I       sNx, sNy, Nr, ncvargrdtmp, 'Arr3D', costFinalExist,
5cf4364659 Mart*0258      I       myThid )
                0259 #ifndef ALLOW_OPENAD
                0260        ENDIF
                0261 #endif
                0262       ENDDO
                0263 #endif /* ALLOW_GENARR3D_CONTROL */
                0264 
                0265 C----------------------------------------------------------------------
                0266 
                0267 #ifdef ALLOW_GENTIM2D_CONTROL
                0268       DO iarr = 1, maxCtrlTim2D
                0269 
                0270 #ifdef ALLOW_CAL
                0271        IF (xx_gentim2d_startdate1(iarr).EQ.0) THEN
                0272           xx_gentim2d_startdate1(iarr)=startdate_1
                0273           xx_gentim2d_startdate2(iarr)=startdate_2
                0274        ENDIF
                0275 #endif
                0276        ncvargrdtmp='c'
                0277 # ifdef ALLOW_SHELFICE
                0278 C      Under iceshelf, use maskSHI for these
                0279        IF (xx_gentim2d_file(iarr)(1:11).EQ.'xx_shifwflx')
                0280      &       ncvargrdtmp='i'
                0281 # endif
                0282        IF (xx_gentim2d_file(iarr)(1:5).EQ.'xx_fu')
                0283      &       ncvargrdtmp='w'
                0284        IF (xx_gentim2d_file(iarr)(1:5).EQ.'xx_fv')
                0285      &       ncvargrdtmp='s'
                0286 
                0287        CALL ctrl_init_rec ( xx_gentim2d_file(iarr),
                0288      I       xx_gentim2d_startdate1(iarr),
                0289      I       xx_gentim2d_startdate2(iarr),
                0290      I       xx_gentim2d_period(iarr),
                0291      I       1,
                0292      O       xx_gentim2d_startdate(1,iarr),
                0293      O       diffrec, startrec, endrec,
                0294      I       myThid )
                0295 
                0296 #ifndef ALLOW_OPENAD
                0297        IF (xx_gentim2d_weight(iarr).NE.' ') THEN
                0298 #endif
                0299         DO k2 = 1, maxCtrlProc
                0300          IF (xx_gentim2d_preproc(k2,iarr).EQ.'replicate')
                0301      &    xx_gentim2d_preproc(k2,iarr)='docycle'
                0302          IF (xx_gentim2d_preproc(k2,iarr).EQ.'doglomean')
                0303      &    xx_gentim2d_glosum(iarr)     = .TRUE.
                0304          IF (xx_gentim2d_preproc(k2,iarr).EQ.'documul')
                0305      &    xx_gentim2d_cumsum(iarr)     = .TRUE.
                0306         ENDDO
                0307 
                0308         diffrecFull=diffrec
                0309         endrecFull=endrec
                0310         DO k2 = 1, maxCtrlProc
                0311           IF (xx_gentim2d_preproc(k2,iarr).EQ.'docycle') THEN
                0312            IF (xx_gentim2d_preproc_i(k2,iarr).NE.0) THEN
                0313             diffrec=min(diffrec,xx_gentim2d_preproc_i(k2,iarr))
                0314             endrec=min(endrec,xx_gentim2d_preproc_i(k2,iarr))
                0315            ENDIF
                0316           ENDIF
                0317         ENDDO
                0318 
                0319         ivar = ivar+1
                0320         ilgen = ILNBLNK( xx_gentim2d_file(iarr) )
                0321         WRITE(fnamegen,'(2a)')
                0322      &       xx_gentim2d_file(iarr)(1:ilgen),'.effective'
                0323         CALL ctrl_init_ctrlvar (
                0324      I       fnamegen,
                0325      I       0, iarr,
                0326      I       diffrecFull, startrec, endrecFull,
acacc28f7f Jean*0327      I       sNx, sNy, 1, ncvargrdtmp, 'Tim2D', costFinalExist,
5cf4364659 Mart*0328      I       myThid )
                0329 
                0330         WRITE(fnamegen,'(2a)')
                0331      &       xx_gentim2d_file(iarr)(1:ilgen),'.tmp'
                0332         CALL ctrl_init_ctrlvar (
                0333      I       fnamegen,
                0334      I       0, iarr,
                0335      I       diffrecFull, startrec, endrecFull,
acacc28f7f Jean*0336      I       sNx, sNy, 1, ncvargrdtmp, 'Tim2D', costFinalExist,
5cf4364659 Mart*0337      I       myThid )
                0338 
                0339 C     The length of adxx-files needs to be 1:endrec
                0340         CALL ctrl_init_ctrlvar (
                0341      I       xx_gentim2d_file(iarr),
                0342      I       ivar, iarr,
                0343      I       endrec, 1, endrec,
acacc28f7f Jean*0344      I       sNx, sNy, 1, ncvargrdtmp, 'Tim2D', costFinalExist,
5cf4364659 Mart*0345      I       myThid )
                0346 
                0347 #ifndef ALLOW_OPENAD
                0348        ENDIF
                0349 #endif
                0350 
                0351       ENDDO
                0352 #endif /* ALLOW_GENTIM2D_CONTROL */
                0353 
                0354 C----------------------------------------------------------------------
                0355 
                0356 C--   short report before calling INIT_WET:
                0357       WRITE(msgBuf,'(2A,I4,A)') 'CTRL_INIT_FIXED: ',
                0358      &     'ivar=', ivar, ' = number of CTRL variables defined'
                0359       CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0360      &                    SQUEEZE_RIGHT, myThid )
                0361       WRITE(msgBuf,'(A)') ' '
                0362       CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0363      &                    SQUEEZE_RIGHT, myThid )
                0364 
                0365 C----------------------------------------------------------------------
                0366 
                0367       CALL CTRL_INIT_WET( myThid )
                0368 
                0369 #ifdef ALLOW_DIC_CONTROL
                0370       DO i = 1, dic_n_control
                0371        xx_dic(i) = 0. _d 0
                0372       ENDDO
                0373 #endif
                0374 
                0375 C----------------------------------------------------------------------
                0376 
                0377       _BARRIER
                0378 
                0379 C--   Summarize the CTRL package setup.
                0380       _BEGIN_MASTER( myThid )
                0381       CALL CTRL_SUMMARY( myThid )
                0382       _END_MASTER( myThid )
                0383 
                0384       RETURN
                0385       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!