Back to home page

MITgcm
 
 

    

File indexing completed on 2024-03-02 06:10:19 UTC

view on githubraw file Latest commit 5cf43646 on 2024-03-01 18:50:49 UTC
7bfe6112e8 Jean*0001 #include "CTRL_OPTIONS.h"
df9b11254f Jean*0002 #ifdef ALLOW_COST
                0003 # include "COST_OPTIONS.h"
                0004 #endif
9bf2145f01 Gael*0005 #ifdef ALLOW_ECCO
                0006 # include "ECCO_OPTIONS.h"
                0007 #endif
2dcaa8b9a5 Patr*0008 
4c6316f049 Patr*0009       subroutine ctrl_pack( first, mythid )
7109a141b2 Patr*0010 
                0011 c     ==================================================================
                0012 c     SUBROUTINE ctrl_pack
                0013 c     ==================================================================
                0014 c
                0015 c     o Compress the control vector such that only ocean points are
                0016 c       written to file.
                0017 c
                0018 c     started: Christian Eckert eckert@mit.edu  10-Mar=2000
                0019 c
                0020 c     changed: Patrick Heimbach heimbach@mit.edu 06-Jun-2000
                0021 c              - Transferred some filename declarations
5cf4364659 Mart*0022 c                from here to namelist in ctrl_init_fixed
5b80ef1e8d Jean*0023 c
7109a141b2 Patr*0024 c              Patrick Heimbach heimbach@mit.edu 16-Jun-2000
                0025 c              - single file name convention with or without
                0026 c                ALLOW_ECCO_OPTIMIZATION
                0027 c
                0028 c              G. Gebbie, added open boundary control packing,
                0029 c                  gebbie@mit.edu  18 -Mar- 2003
                0030 c
dff4940422 Patr*0031 c              heimbach@mit.edu totally restructured 28-Oct-2003
4c6316f049 Patr*0032 c
7109a141b2 Patr*0033 c     ==================================================================
                0034 c     SUBROUTINE ctrl_pack
                0035 c     ==================================================================
                0036 
5cf4364659 Mart*0037       IMPLICIT NONE
2dcaa8b9a5 Patr*0038 
                0039 c     == global variables ==
5d5c0b0d52 Patr*0040 
2dcaa8b9a5 Patr*0041 #include "EEPARAMS.h"
                0042 #include "SIZE.h"
                0043 #include "PARAMS.h"
                0044 #include "GRID.h"
5d5c0b0d52 Patr*0045 
e612621177 Gael*0046 #ifdef ALLOW_CTRL
                0047 # include "CTRL_SIZE.h"
5cf4364659 Mart*0048 # include "CTRL.h"
e612621177 Gael*0049 # include "CTRL_GENARR.h"
65754df434 Mart*0050 # include "OPTIMCYCLE.h"
e612621177 Gael*0051 # include "CTRL_OBCS.h"
                0052 #endif
170b439592 Patr*0053 #ifdef ALLOW_COST
                0054 # include "cost.h"
                0055 #endif
dff4940422 Patr*0056 
2dcaa8b9a5 Patr*0057 c     == routine arguments ==
4c6316f049 Patr*0058       logical first
2dcaa8b9a5 Patr*0059       integer mythid
                0060 
4c6316f049 Patr*0061 #ifndef EXCLUDE_CTRL_PACK
f9d7cbfb72 Ou W*0062 c     == external functions ==
                0063 
                0064       integer  ilnblnk
                0065       external ilnblnk
                0066 
2dcaa8b9a5 Patr*0067 c     == local variables ==
                0068 
9f5240b52a Jean*0069       logical doglobalread
                0070       logical ladinit
                0071       logical lxxadxx
4c6316f049 Patr*0072 
5cf4364659 Mart*0073       integer k, ivar, iarr
9f5240b52a Jean*0074       integer cunit
                0075       integer ictrlgrad
                0076       _RL    fcloc
                0077 
                0078       character*(128) cfile
5cf4364659 Mart*0079       integer il, ilDir
9f5240b52a Jean*0080 
de57a2ec4b Mart*0081       character*(MAX_LEN_FNAM) fname_local(3)
5cf4364659 Mart*0082 
9f5240b52a Jean*0083 #if ( defined ALLOW_GENARR2D_CONTROL || defined ALLOW_GENTIM2D_CONTROL )
                0084 C 9 character limit set by set_(un)pack
5cf4364659 Mart*0085       character*(9) mskNameForSetPack
                0086 #endif
                0087 
                0088 #ifdef ALLOW_OBCS
                0089       integer iobcs
9f5240b52a Jean*0090 #endif
2dcaa8b9a5 Patr*0091 
                0092 c     == end of interface ==
                0093 
                0094 c--   Tiled files are used.
                0095       doglobalread = .false.
                0096 
                0097 c--   Initialise adjoint variables on active files.
                0098       ladinit = .false.
                0099 
8f0b59c61c Patr*0100 c--   Initialise global buffer index
                0101       nbuffglobal = 0
                0102 
37e373688b Mart*0103 c--   Initialise local cost function value
                0104       fcloc     = zeroRL
                0105 
f9d7cbfb72 Ou W*0106 c--   Find ctrlDir (w/o trailing blanks) length
                0107       ilDir = ilnblnk(ctrlDir)
                0108 
45913d6a59 Patr*0109 c--   Only the master thread will do I/O.
2dcaa8b9a5 Patr*0110       _BEGIN_MASTER( mythid )
                0111 
d04f98ba8f Patr*0112       if ( first ) then
4c6316f049 Patr*0113 c     >>> Initialise control vector for optimcycle=0 <<<
                0114           lxxadxx   = .TRUE.
                0115           ictrlgrad = 1
37e373688b Mart*0116           fcloc     = zeroRL
4c6316f049 Patr*0117           write(cfile(1:128),'(4a,i4.4)')
5b80ef1e8d Jean*0118      &         ctrlname(1:9),'_',yctrlid(1:10),
d04f98ba8f Patr*0119      &         yctrlpospack, optimcycle
344ddc3242 Mart*0120           write(standardMessageUnit,*) 'ph-pack: packing ',ctrlname(1:9)
4c6316f049 Patr*0121       else
2dcaa8b9a5 Patr*0122 c     >>> Write gradient vector <<<
4c6316f049 Patr*0123           lxxadxx   = .FALSE.
                0124           ictrlgrad = 2
c433ed6869 Gael*0125 #ifdef ALLOW_COST
                0126 # ifdef ALLOW_OPENAD
60e3924f90 Patr*0127           fcloc     = fc%v
c433ed6869 Gael*0128 # else
4c6316f049 Patr*0129           fcloc     = fc
c433ed6869 Gael*0130 # endif
60e3924f90 Patr*0131 #endif
5d5c0b0d52 Patr*0132           write(cfile(1:128),'(4a,i4.4)')
5b80ef1e8d Jean*0133      &         costname(1:9),'_',yctrlid(1:10),
d04f98ba8f Patr*0134      &         yctrlpospack, optimcycle
344ddc3242 Mart*0135           write(standardMessageUnit,*) 'ph-pack: packing ',costname(1:9)
4c6316f049 Patr*0136        endif
2dcaa8b9a5 Patr*0137 
7807741270 Gael*0138 c--   Only Proc 0 will do I/O.
                0139       IF ( myProcId .eq. 0 ) THEN
                0140 
4c6316f049 Patr*0141        call mdsfindunit( cunit, mythid )
                0142        open( cunit, file   = cfile,
                0143      &      status = 'unknown',
                0144      &      form   = 'unformatted',
                0145      &      access  = 'sequential'   )
2dcaa8b9a5 Patr*0146 
                0147 c--       Header information.
5a356b90da Mart*0148           write(cunit) nvartype
                0149           write(cunit) nvarlength
                0150           write(cunit) yctrlid
                0151           write(cunit) optimCycle
37e373688b Mart*0152           write(cunit) fcloc
5a356b90da Mart*0153 C     place holder of obsolete variable iG
                0154           write(cunit) 1
                0155 C     place holder of obsolete variable jG
                0156           write(cunit) 1
f9d7cbfb72 Ou W*0157           write(cunit) nSx
                0158           write(cunit) nSy
                0159           write(cunit) (nWetcGlobal(k), k=1,Nr)
                0160           write(cunit) (nWetsGlobal(k), k=1,Nr)
                0161           write(cunit) (nWetwGlobal(k), k=1,Nr)
5cf4364659 Mart*0162 c#ifdef ALLOW_CTRL_WETV
                0163 c         write(cunit) (nWetvGlobal(k), k=1,Nr)
                0164 c#endif
7b8b86ab99 Timo*0165 #ifdef ALLOW_SHELFICE
f9d7cbfb72 Ou W*0166           write(cunit) (nWetiGlobal(k), k=1,Nr)
1d82288286 Mart*0167 c          write(cunit) nWetiGlobal(1)
                0168 #endif
4c6316f049 Patr*0169 
cf705a6c8e Mart*0170 #ifdef ALLOW_OBCS
5cf4364659 Mart*0171 # ifdef ALLOW_OBCSN_CONTROL
f9d7cbfb72 Ou W*0172           write(cunit) ((nWetobcsnGlo(k,iobcs), k=1,Nr),iobcs= 1,nobcs)
5cf4364659 Mart*0173 # endif
                0174 # ifdef ALLOW_OBCSS_CONTROL
f9d7cbfb72 Ou W*0175           write(cunit) ((nWetobcssGlo(k,iobcs), k=1,Nr),iobcs= 1,nobcs)
5cf4364659 Mart*0176 # endif
                0177 # ifdef ALLOW_OBCSW_CONTROL
f9d7cbfb72 Ou W*0178           write(cunit) ((nWetobcswGlo(k,iobcs), k=1,Nr),iobcs= 1,nobcs)
5cf4364659 Mart*0179 # endif
                0180 # ifdef ALLOW_OBCSE_CONTROL
f9d7cbfb72 Ou W*0181           write(cunit) ((nWetobcseGlo(k,iobcs), k=1,Nr),iobcs= 1,nobcs)
5cf4364659 Mart*0182 # endif
cf705a6c8e Mart*0183 #endif
e612621177 Gael*0184 
5cf4364659 Mart*0185           write(cunit) (ncvarindex(ivar), ivar=1,nvartype)
                0186           write(cunit) (ncvarrecs(ivar),  ivar=1,nvartype)
                0187           write(cunit) (ncvarxmax(ivar),  ivar=1,nvartype)
                0188           write(cunit) (ncvarymax(ivar),  ivar=1,nvartype)
                0189           write(cunit) (ncvarnrmax(ivar), ivar=1,nvartype)
                0190           write(cunit) (ncvargrd(ivar),   ivar=1,nvartype)
                0191           write(cunit) (ncvartype(ivar),  ivar=1,nvartype)
2dcaa8b9a5 Patr*0192 
23a37235f2 Gael*0193 #ifdef ALLOW_PACKUNPACK_METHOD2
7807741270 Gael*0194       ENDIF
                0195       _END_MASTER( mythid )
                0196       _BARRIER
                0197 #endif
                0198 
5cf4364659 Mart*0199 c     do ivar = 1, maxcvars
                0200       do ivar = 1, nvartype
                0201        if ( ncvarindex(ivar) .GE. 0 ) THEN
                0202         il = ilnblnk(ncvarfname(ivar))
                0203         iarr = ncvarindex(ivar)
                0204         call ctrl_set_fname(ctrlDir(1:ilDir)//ncvarfname(ivar),
                0205      &                      fname_local, mythid )
                0206         if ( ncvargrd(ivar).EQ.'m' ) then
cf705a6c8e Mart*0207 #ifdef ALLOW_OBCS
5cf4364659 Mart*0208          if ( iarr.EQ.1 ) then
                0209 # ifdef ALLOW_OBCSN_CONTROL
                0210           call ctrl_set_pack_xz( cunit, ivar, fname_local(ictrlgrad),
                0211      &               'maskobcsn', 'wobcsn', wobcsn, lxxadxx, mythid )
                0212 # endif
                0213          elseif ( iarr.EQ.2 ) then
                0214 # ifdef ALLOW_OBCSS_CONTROL
                0215           call ctrl_set_pack_xz( cunit, ivar, fname_local(ictrlgrad),
                0216      &               'maskobcss', 'wobcss', wobcss, lxxadxx, mythid )
                0217 # endif
                0218          elseif ( iarr.EQ.3 ) then
                0219 # ifdef ALLOW_OBCSE_CONTROL
                0220           call ctrl_set_pack_yz( cunit, ivar, fname_local(ictrlgrad),
                0221      &               'maskobcse', 'wobcse', wobcse, lxxadxx, mythid )
                0222 # endif
                0223          elseif ( iarr.EQ.4 ) then
                0224 # ifdef ALLOW_OBCSW_CONTROL
                0225           call ctrl_set_pack_yz( cunit, ivar, fname_local(ictrlgrad),
                0226      &               'maskobcsw', 'wobcsw', wobcsw, lxxadxx, mythid )
                0227 # endif
                0228          endif
cf705a6c8e Mart*0229 #endif /* ALLOW_OBCS */
61a813cf9a Gael*0230 
e901366860 Patr*0231 #ifdef ALLOW_GENARR2D_CONTROL
5cf4364659 Mart*0232         elseif ( ncvartype(ivar).EQ.'Arr2D' ) then
                0233          if ( xx_genarr2d_weight(iarr).NE.' ') then
                0234           mskNameForSetPack='maskCtrlC'
7b8b86ab99 Timo*0235 # ifdef ALLOW_SHELFICE
5cf4364659 Mart*0236           if ( ncvargrd(ivar).EQ.'i' ) mskNameForSetPack='maskCtrlI'
7b8b86ab99 Timo*0237 # endif
e901366860 Patr*0238           call ctrl_set_pack_xy(
5cf4364659 Mart*0239      &         cunit, ivar, genarr2dPrecond(iarr),
7b8b86ab99 Timo*0240      &         fname_local(ictrlgrad), mskNameForSetPack,
df9b11254f Jean*0241      &         xx_genarr2d_weight(iarr),
5cf4364659 Mart*0242      &         lxxadxx, mythid )
                0243          endif
9f5240b52a Jean*0244 #endif /* ALLOW_GENARR2D_CONTROL */
e901366860 Patr*0245 
                0246 #ifdef ALLOW_GENARR3D_CONTROL
5cf4364659 Mart*0247         elseif ( ncvartype(ivar).EQ.'Arr3D' ) then
                0248          if ( xx_genarr3d_weight(iarr).NE.' ') then
e901366860 Patr*0249           call ctrl_set_pack_xyz(
5cf4364659 Mart*0250      &         cunit, ivar, fname_local(ictrlgrad), 'maskCtrlC',
df9b11254f Jean*0251      &         xx_genarr3d_weight(iarr),
5cf4364659 Mart*0252      &         wunit, lxxadxx, mythid )
                0253          endif
9f5240b52a Jean*0254 #endif /* ALLOW_GENARR3D_CONTROL */
e901366860 Patr*0255 
7bd66d7dc3 Patr*0256 #ifdef ALLOW_GENTIM2D_CONTROL
5cf4364659 Mart*0257         elseif ( ncvartype(ivar).EQ.'Tim2D' ) then
                0258          if ( xx_gentim2d_weight(iarr).NE.' ') then
                0259           mskNameForSetPack='maskCtrlC'
7b8b86ab99 Timo*0260 # ifdef ALLOW_SHELFICE
5cf4364659 Mart*0261           if ( ncvargrd(ivar).EQ.'i' ) mskNameForSetPack='maskCtrlI'
7b8b86ab99 Timo*0262 # endif
7bd66d7dc3 Patr*0263           call ctrl_set_pack_xy(
5cf4364659 Mart*0264      &         cunit, ivar, gentim2dPrecond(iarr),
7b8b86ab99 Timo*0265      &         fname_local(ictrlgrad), mskNameForSetPack,
df9b11254f Jean*0266      &         xx_gentim2d_weight(iarr),
5cf4364659 Mart*0267      &         lxxadxx, mythid )
                0268          endif
9f5240b52a Jean*0269 #endif /* ALLOW_GENTIM2D_CONTROL */
5cf4364659 Mart*0270         endif
                0271 C     if ( ncvarindex(ivar) .ge. 0 ) then
                0272        endif
                0273 C     do ivar = 1, maxcvars
                0274       enddo
7bd66d7dc3 Patr*0275 
23a37235f2 Gael*0276 #ifdef ALLOW_PACKUNPACK_METHOD2
7807741270 Gael*0277       _BEGIN_MASTER( mythid )
                0278       IF ( myProcId .eq. 0 ) THEN
                0279 #endif
5d5c0b0d52 Patr*0280 
7807741270 Gael*0281        close ( cunit )
5b80ef1e8d Jean*0282        ENDIF !IF ( myProcId .eq. 0 )
7807741270 Gael*0283        _END_MASTER( mythid )
                0284       _BARRIER
4c6316f049 Patr*0285 #endif /* EXCLUDE_CTRL_PACK */
                0286 
2dcaa8b9a5 Patr*0287       return
                0288       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!