Back to home page

MITgcm
 
 

    

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

view on githubraw file Latest commit 5cf43646 on 2024-03-01 18:50:49 UTC
7bfe6112e8 Jean*0001 #include "CTRL_OPTIONS.h"
5d5c0b0d52 Patr*0002 
                0003       subroutine ctrl_set_unpack_xy(
5cf4364659 Mart*0004      &     lxxadxx, cunit, ivar, PrecondScalar,
0758474a8b Jean*0005      &     fname, masktype, weighttype,
4d72283393 Mart*0006      &     nwetglobal, myThid )
5d5c0b0d52 Patr*0007 
                0008 c     ==================================================================
                0009 c     SUBROUTINE ctrl_set_unpack_xy
                0010 c     ==================================================================
                0011 c
                0012 c     o Unpack the control vector such that the land points are filled
                0013 c       in.
                0014 c
                0015 c     ==================================================================
                0016 
                0017       implicit none
                0018 
                0019 c     == global variables ==
                0020 
                0021 #include "EEPARAMS.h"
                0022 #include "SIZE.h"
                0023 #include "PARAMS.h"
                0024 #include "GRID.h"
                0025 
5cf4364659 Mart*0026 #include "CTRL_SIZE.h"
4d72283393 Mart*0027 #include "CTRL.h"
65754df434 Mart*0028 #include "OPTIMCYCLE.h"
5d5c0b0d52 Patr*0029 
                0030 c     == routine arguments ==
                0031 
0ba65c94ff Patr*0032       logical lxxadxx
5d5c0b0d52 Patr*0033       integer cunit
5cf4364659 Mart*0034       integer ivar
3145d51f22 Patr*0035       _RL precondScalar
de57a2ec4b Mart*0036       character*(MAX_LEN_FNAM) fname
0758474a8b Jean*0037       character*(  9) masktype
de57a2ec4b Mart*0038       character*(MAX_LEN_FNAM) weighttype
9f5240b52a Jean*0039       integer nwetglobal(Nr)
4d72283393 Mart*0040       integer myThid
5d5c0b0d52 Patr*0041 
dac57cef35 Patr*0042 #ifndef EXCLUDE_CTRL_PACK
9f5240b52a Jean*0043 c     == external ==
                0044       integer  ilnblnk
                0045       external ilnblnk
5d5c0b0d52 Patr*0046 
9f5240b52a Jean*0047 c     == local variables ==
5d5c0b0d52 Patr*0048       integer bi,bj
                0049       integer i,j,k
9f5240b52a Jean*0050       integer ii, irec
                0051       integer cbuffindex
                0052       real*4 cbuff( sNx*nSx*nPx*sNy*nSy*nPy )
de57a2ec4b Mart*0053       character*(MAX_LEN_FNAM) cfile2, cfile3
5cf4364659 Mart*0054 C     These variables are read-in from file, but not used much
                0055       integer loc_ncbuffindex
                0056       integer loc_i
                0057       integer loc_j
                0058       integer loc_k
                0059       integer loc_ncvarindex
                0060 
9f5240b52a Jean*0061 C========================================================================
                0062 # ifndef ALLOW_PACKUNPACK_METHOD2
                0063       integer ip,jp
                0064       integer nrec_nl
5d5c0b0d52 Patr*0065       integer itlo,ithi
                0066       integer jtlo,jthi
                0067       integer jmin,jmax
                0068       integer imin,imax
9f5240b52a Jean*0069       _RL     globmsk  ( sNx,nSx,nPx,sNy,nSy,nPy,Nr )
                0070       _RL     globfld3d( sNx,nSx,nPx,sNy,nSy,nPy,Nr )
                0071       integer reclen, irectrue
0ba65c94ff Patr*0072       integer cunit2, cunit3
9f5240b52a Jean*0073       real*4 globfldtmp2( sNx,nSx,nPx,sNy,nSy,nPy )
                0074       real*4 globfldtmp3( sNx,nSx,nPx,sNy,nSy,nPy )
                0075 # else /* ALLOW_PACKUNPACK_METHOD2 */
                0076       integer il
                0077       _RL msk3d(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr,nSx,nSy)
                0078       real*8 msk2d_buf(sNx,sNy,nSx,nSy)
                0079       real*8 msk2d_buf_glo(Nx,Ny)
                0080       real*8 fld2d_buf(sNx,sNy,nSx,nSy)
                0081       real*8 fld2d_buf_glo(Nx,Ny)
                0082       _RL fld2dDim(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
                0083       _RL fld2dNodim(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
                0084       _RL dummy
                0085 # endif /* ALLOW_PACKUNPACK_METHOD2 */
5d5c0b0d52 Patr*0086 c     == end of interface ==
                0087 
9f5240b52a Jean*0088 # ifndef ALLOW_PACKUNPACK_METHOD2
                0089 
5d5c0b0d52 Patr*0090       jtlo = 1
9f5240b52a Jean*0091       jthi = nSy
5d5c0b0d52 Patr*0092       itlo = 1
9f5240b52a Jean*0093       ithi = nSx
5d5c0b0d52 Patr*0094       jmin = 1
9f5240b52a Jean*0095       jmax = sNy
5d5c0b0d52 Patr*0096       imin = 1
9f5240b52a Jean*0097       imax = sNx
5d5c0b0d52 Patr*0098 
8f0b59c61c Patr*0099       nbuffGlobal = nbuffGlobal + 1
                0100 
5d5c0b0d52 Patr*0101 c     Initialise temporary file
9f5240b52a Jean*0102       do k = 1,Nr
3145d51f22 Patr*0103        do jp = 1,nPy
                0104         do bj = jtlo,jthi
                0105          do j = jmin,jmax
                0106           do ip = 1,nPx
                0107            do bi = itlo,ithi
                0108             do i = imin,imax
                0109              globfld3d  (i,bi,ip,j,bj,jp,k) = 0. _d 0
                0110              globmsk    (i,bi,ip,j,bj,jp,k) = 0. _d 0
                0111              globfldtmp2(i,bi,ip,j,bj,jp)   = 0. _d 0
                0112              globfldtmp3(i,bi,ip,j,bj,jp)   = 0. _d 0
5d5c0b0d52 Patr*0113             enddo
3145d51f22 Patr*0114            enddo
                0115           enddo
5d5c0b0d52 Patr*0116          enddo
3145d51f22 Patr*0117         enddo
                0118        enddo
5d5c0b0d52 Patr*0119       enddo
                0120 
                0121 c--   Only the master thread will do I/O.
4d72283393 Mart*0122       _BEGIN_MASTER( myThid )
5d5c0b0d52 Patr*0123 
0ba65c94ff Patr*0124       if ( doPackDiag ) then
                0125          if ( lxxadxx ) then
de57a2ec4b Mart*0126             write(cfile2,'(a,I3.3,a,I4.4,a)')
951926fb9b Jean*0127      &           'diag_unpack_nondim_ctrl_',
5cf4364659 Mart*0128      &           ivar, '_', optimcycle, '.bin'
de57a2ec4b Mart*0129             write(cfile3,'(a,I3.3,a,I4.4,a)')
951926fb9b Jean*0130      &           'diag_unpack_dimens_ctrl_',
5cf4364659 Mart*0131      &           ivar, '_', optimcycle, '.bin'
0ba65c94ff Patr*0132          else
de57a2ec4b Mart*0133             write(cfile2,'(a,I3.3,a,I4.4,a)')
951926fb9b Jean*0134      &           'diag_unpack_nondim_grad_',
5cf4364659 Mart*0135      &           ivar, '_', optimcycle, '.bin'
de57a2ec4b Mart*0136             write(cfile3,'(a,I3.3,a,I4.4,a)')
951926fb9b Jean*0137      &           'diag_unpack_dimens_grad_',
5cf4364659 Mart*0138      &           ivar, '_', optimcycle, '.bin'
0ba65c94ff Patr*0139          endif
                0140 
9f5240b52a Jean*0141          reclen = FLOAT(sNx*nSx*nPx*sNy*nSy*nPy*4)
4d72283393 Mart*0142          call mdsfindunit( cunit2, myThid )
b052f6c8f1 Patr*0143          open( cunit2, file=cfile2, status='unknown',
0ba65c94ff Patr*0144      &        access='direct', recl=reclen )
4d72283393 Mart*0145          call mdsfindunit( cunit3, myThid )
b052f6c8f1 Patr*0146          open( cunit3, file=cfile3, status='unknown',
0ba65c94ff Patr*0147      &        access='direct', recl=reclen )
                0148       endif
                0149 
951926fb9b Jean*0150       call MDSREADFIELD_3D_GL(
5d5c0b0d52 Patr*0151      &     masktype, ctrlprec, 'RL',
4d72283393 Mart*0152      &     Nr, globmsk, 1, myThid)
5d5c0b0d52 Patr*0153 
5cf4364659 Mart*0154       nrec_nl=int(ncvarrecs(ivar)/Nr)
7109a141b2 Patr*0155       do irec = 1, nrec_nl
                0156          do k = 1,Nr
9f5240b52a Jean*0157          irectrue = (irec-1)*Nr + k
faf44775ba Patr*0158 #ifndef ALLOW_ADMTLM
5cf4364659 Mart*0159          read(cunit) loc_ncvarindex
                0160          if (loc_ncvarindex .NE. ncvarindex(ivar)) then
                0161             IF ( irec.EQ.1 )
                0162      &      print *, 'ctrl_set_unpack_xy:WARNING: wrong ncvarindex ',
                0163      &           loc_ncvarindex, ncvarindex(ivar)
                0164 # ifndef READ_OLD_CTRL_PACK_FILE
f5635c29ac Mart*0165             STOP 'in S/R ctrl_set_unpack_xy'
5cf4364659 Mart*0166 # endif
7109a141b2 Patr*0167          endif
5cf4364659 Mart*0168          read(cunit) loc_j
                0169          read(cunit) loc_i
faf44775ba Patr*0170 #endif /* ndef ALLOW_ADMTLM */
7109a141b2 Patr*0171             cbuffindex = nwetglobal(1)
                0172             if ( cbuffindex .gt. 0 ) then
faf44775ba Patr*0173 #ifndef ALLOW_ADMTLM
5cf4364659 Mart*0174                read(cunit) loc_ncbuffindex
                0175                if (loc_ncbuffindex .NE. cbuffindex) then
7109a141b2 Patr*0176                   print *, 'WARNING: wrong cbuffindex ',
5cf4364659 Mart*0177      &                 loc_ncbuffindex, cbuffindex
f5635c29ac Mart*0178                   STOP 'in S/R ctrl_set_unpack_xy'
7109a141b2 Patr*0179                endif
5cf4364659 Mart*0180                read(cunit) loc_k
                0181                if (loc_k .NE. 1) then
7109a141b2 Patr*0182                   print *, 'WARNING: wrong k ',
5cf4364659 Mart*0183      &                 loc_k, 1
f5635c29ac Mart*0184                   STOP 'in S/R ctrl_set_unpack_xy'
7109a141b2 Patr*0185                endif
e324d8bc16 Patr*0186 cph#endif /* ndef ALLOW_ADMTLM */
7109a141b2 Patr*0187                read(cunit) (cbuff(ii), ii=1,cbuffindex)
e324d8bc16 Patr*0188 #endif /* ndef ALLOW_ADMTLM */
7109a141b2 Patr*0189             endif
faf44775ba Patr*0190 c
7109a141b2 Patr*0191             cbuffindex = 0
                0192             do jp = 1,nPy
                0193              do bj = jtlo,jthi
                0194               do j = jmin,jmax
                0195                do ip = 1,nPx
                0196                 do bi = itlo,ithi
                0197                  do i = imin,imax
                0198                   if ( globmsk(i,bi,ip,j,bj,jp,1) .ne. 0. ) then
                0199                      cbuffindex = cbuffindex + 1
                0200                      globfld3d(i,bi,ip,j,bj,jp,k) = cbuff(cbuffindex)
efc45565af Patr*0201 cph(
                0202                      globfldtmp2(i,bi,ip,j,bj,jp) = cbuff(cbuffindex)
                0203 cph)
faf44775ba Patr*0204 #ifdef ALLOW_ADMTLM
                0205                      nveccount = nveccount + 1
951926fb9b Jean*0206                      globfld3d(i,bi,ip,j,bj,jp,k) =
85a8618ded Patr*0207      &                 phtmpadmtlm(nveccount)
                0208 cph(
951926fb9b Jean*0209                      globfldtmp2(i,bi,ip,j,bj,jp) =
85a8618ded Patr*0210      &                 phtmpadmtlm(nveccount)
                0211 cph)
faf44775ba Patr*0212 #endif
3145d51f22 Patr*0213                       if ( lxxadxx ) then
cc7fa87b6d Gael*0214                         globfld3d(i,bi,ip,j,bj,jp,k) =
                0215      &                       globfld3d(i,bi,ip,j,bj,jp,k)
3145d51f22 Patr*0216      &                       * precondScalar
                0217                       else
cc7fa87b6d Gael*0218                         globfld3d(i,bi,ip,j,bj,jp,k) =
                0219      &                       globfld3d(i,bi,ip,j,bj,jp,k)
3145d51f22 Patr*0220      &                       / precondScalar
                0221                       endif
7109a141b2 Patr*0222                   else
                0223                      globfld3d(i,bi,ip,j,bj,jp,k) = 0. _d 0
efc45565af Patr*0224                   endif
                0225 cph(
                0226                   globfldtmp3(i,bi,ip,j,bj,jp) =
                0227      &                 globfld3d(i,bi,ip,j,bj,jp,k)
                0228 cph)
                0229                   enddo
7109a141b2 Patr*0230                 enddo
                0231                enddo
                0232               enddo
                0233              enddo
                0234             enddo
efc45565af Patr*0235 cph(
                0236             if ( doPackDiag ) then
                0237                write(cunit2,rec=irectrue) globfldtmp2
                0238                write(cunit3,rec=irectrue) globfldtmp3
                0239             endif
                0240 cph)
7109a141b2 Patr*0241          enddo
                0242 
                0243          call MDSWRITEFIELD_3D_GL( fname, ctrlprec, 'RL',
                0244      &                             NR, globfld3d,
4d72283393 Mart*0245      &                             irec,  optimcycle, myThid)
7109a141b2 Patr*0246 
                0247       enddo
                0248 
5cf4364659 Mart*0249       do irec = nrec_nl*Nr+1,ncvarrecs(ivar)
a5276edbc9 Patr*0250 #ifndef ALLOW_ADMTLM
5cf4364659 Mart*0251          read(cunit) loc_ncvarindex
                0252          if (loc_ncvarindex .NE. ncvarindex(ivar)) then
                0253             IF ( irec.EQ.1 )
                0254      &      print *, 'ctrl_set_unpack_xy:WARNING: wrong ncvarindex ',
                0255      &           loc_ncvarindex, ncvarindex(ivar)
                0256 # ifndef READ_OLD_CTRL_PACK_FILE
f5635c29ac Mart*0257             STOP 'in S/R ctrl_set_unpack_xy'
5cf4364659 Mart*0258 # endif
5d5c0b0d52 Patr*0259          endif
5cf4364659 Mart*0260          read(cunit) loc_j
                0261          read(cunit) loc_i
faf44775ba Patr*0262 #endif /* ALLOW_ADMTLM */
5d5c0b0d52 Patr*0263          do k = 1,1
0ba65c94ff Patr*0264             irectrue = irec
5d5c0b0d52 Patr*0265             cbuffindex = nwetglobal(k)
                0266             if ( cbuffindex .gt. 0 ) then
faf44775ba Patr*0267 #ifndef ALLOW_ADMTLM
5cf4364659 Mart*0268                read(cunit) loc_ncbuffindex
                0269                if (loc_ncbuffindex .NE. cbuffindex) then
5d5c0b0d52 Patr*0270                   print *, 'WARNING: wrong cbuffindex ',
5cf4364659 Mart*0271      &                 loc_ncbuffindex, cbuffindex
f5635c29ac Mart*0272                   STOP 'in S/R ctrl_set_unpack_xy'
5d5c0b0d52 Patr*0273                endif
5cf4364659 Mart*0274                read(cunit) loc_k
                0275                if (loc_k .NE. k) then
5d5c0b0d52 Patr*0276                   print *, 'WARNING: wrong k ',
5cf4364659 Mart*0277      &                 loc_k, k
f5635c29ac Mart*0278                   STOP 'in S/R ctrl_set_unpack_xy'
5d5c0b0d52 Patr*0279                endif
e324d8bc16 Patr*0280 cph#endif /* ALLOW_ADMTLM */
5d5c0b0d52 Patr*0281                read(cunit) (cbuff(ii), ii=1,cbuffindex)
e324d8bc16 Patr*0282 #endif /* ALLOW_ADMTLM */
5d5c0b0d52 Patr*0283             endif
faf44775ba Patr*0284 c
5d5c0b0d52 Patr*0285             cbuffindex = 0
                0286             do jp = 1,nPy
                0287              do bj = jtlo,jthi
                0288               do j = jmin,jmax
                0289                do ip = 1,nPx
                0290                 do bi = itlo,ithi
                0291                  do i = imin,imax
                0292                   if ( globmsk(i,bi,ip,j,bj,jp,k) .ne. 0. ) then
                0293                      cbuffindex = cbuffindex + 1
                0294                      globfld3d(i,bi,ip,j,bj,jp,k) = cbuff(cbuffindex)
efc45565af Patr*0295 cph(
                0296                      globfldtmp2(i,bi,ip,j,bj,jp) = cbuff(cbuffindex)
                0297 cph)
faf44775ba Patr*0298 #ifdef ALLOW_ADMTLM
                0299                      nveccount = nveccount + 1
951926fb9b Jean*0300                      globfld3d(i,bi,ip,j,bj,jp,k) =
85a8618ded Patr*0301      &                 phtmpadmtlm(nveccount)
                0302 cph(
951926fb9b Jean*0303                      globfldtmp2(i,bi,ip,j,bj,jp) =
                0304      &                 phtmpadmtlm(nveccount)
85a8618ded Patr*0305 cph)
faf44775ba Patr*0306 #endif
3145d51f22 Patr*0307                       if ( lxxadxx ) then
951926fb9b Jean*0308                         globfld3d(i,bi,ip,j,bj,jp,k) =
3145d51f22 Patr*0309      &                       globfld3d(i,bi,ip,j,bj,jp,k)
                0310      &                       * precondScalar
                0311                       else
951926fb9b Jean*0312                         globfld3d(i,bi,ip,j,bj,jp,k) =
3145d51f22 Patr*0313      &                       globfld3d(i,bi,ip,j,bj,jp,k)
                0314      &                       / precondScalar
                0315                       endif
5d5c0b0d52 Patr*0316                   else
                0317                      globfld3d(i,bi,ip,j,bj,jp,k) = 0. _d 0
                0318                   endif
efc45565af Patr*0319 cph(
                0320                   globfldtmp3(i,bi,ip,j,bj,jp) =
                0321      &                 globfld3d(i,bi,ip,j,bj,jp,k)
                0322 cph)
5d5c0b0d52 Patr*0323                  enddo
                0324                 enddo
                0325                enddo
                0326               enddo
                0327              enddo
                0328             enddo
efc45565af Patr*0329 cph(
                0330             if ( doPackDiag ) then
                0331                write(cunit2,rec=irectrue) globfldtmp2
                0332                write(cunit3,rec=irectrue) globfldtmp3
                0333             endif
                0334 cph)
5d5c0b0d52 Patr*0335          enddo
951926fb9b Jean*0336 
5d5c0b0d52 Patr*0337          call MDSWRITEFIELD_2D_GL( fname, ctrlprec, 'RL',
                0338      &                             1, globfld3d(1,1,1,1,1,1,1),
4d72283393 Mart*0339      &                             irec,  optimcycle, myThid)
5d5c0b0d52 Patr*0340 
                0341       enddo
                0342 
0ba65c94ff Patr*0343       if ( doPackDiag ) then
                0344          close ( cunit2 )
                0345          close ( cunit3 )
                0346       endif
951926fb9b Jean*0347 
4d72283393 Mart*0348       _END_MASTER( myThid )
5d5c0b0d52 Patr*0349 
9f5240b52a Jean*0350 # else /* ALLOW_PACKUNPACK_METHOD2 */
23a37235f2 Gael*0351 
                0352 c-- part 1: preliminary reads and definitions
                0353 
1c8d09be4c Gael*0354 #ifdef ALLOW_AUTODIFF
cf2ce61250 Jean*0355       call active_read_xyz(masktype, msk3d, 1,
4d72283393 Mart*0356      &    .FALSE., .FALSE., 0 , myThid, dummy)
1c8d09be4c Gael*0357 #else
                0358       CALL READ_REC_XYZ_RL( masktype, msk3d, 1, 1, myThid )
                0359 #endif
23a37235f2 Gael*0360 
                0361       if ( doPackDiag ) then
                0362          il = ilnblnk( fname )
                0363          if ( lxxadxx ) then
de57a2ec4b Mart*0364             write(cfile2,'(2a)') fname(1:il),'.unpack_ctrl_adim'
                0365             write(cfile3,'(2a)') fname(1:il),'.unpack_ctrl_dim'
23a37235f2 Gael*0366          else
de57a2ec4b Mart*0367             write(cfile2,'(2a)') fname(1:il),'.unpack_grad_adim'
                0368             write(cfile3,'(2a)') fname(1:il),'.unpack_grad_dim'
23a37235f2 Gael*0369          endif
                0370       endif
                0371 
                0372 c-- part 2: loop over records
                0373 
5cf4364659 Mart*0374       do irec = 1, ncvarrecs(ivar)
23a37235f2 Gael*0375 
                0376 c-- 2.1: array <- buffer <- global buffer <- global file
                0377 
                0378 #ifndef ALLOW_ADMTLM
4d72283393 Mart*0379       _BEGIN_MASTER( myThid )
23a37235f2 Gael*0380         IF ( myProcId .eq. 0 ) THEN
5cf4364659 Mart*0381          read(cunit) loc_ncvarindex
                0382          if (loc_ncvarindex .NE. ncvarindex(ivar)) then
                0383             IF ( irec.EQ.1 )
                0384      &      print *, 'ctrl_set_unpack_xy:WARNING: wrong ncvarindex ',
                0385      &           loc_ncvarindex, ncvarindex(ivar)
                0386 # ifndef READ_OLD_CTRL_PACK_FILE
f5635c29ac Mart*0387             STOP 'in S/R ctrl_set_unpack_xy'
5cf4364659 Mart*0388 # endif
23a37235f2 Gael*0389          endif
5cf4364659 Mart*0390          read(cunit) loc_j
                0391          read(cunit) loc_i
23a37235f2 Gael*0392         ENDIF
4d72283393 Mart*0393       _END_MASTER( myThid )
23a37235f2 Gael*0394       _BARRIER
                0395 #endif /* ALLOW_ADMTLM */
                0396 
                0397       do k = 1, 1
                0398 
                0399         CALL MDS_PASS_R8toRL( msk2d_buf, msk3d,
cf2ce61250 Jean*0400      &                 0, 0, 1, k, Nr, 0, 0, .FALSE., myThid )
23a37235f2 Gael*0401         CALL BAR2( myThid )
                0402         CALL GATHER_2D_R8( msk2d_buf_glo, msk2d_buf,
                0403      &                       Nx,Ny,.FALSE.,.TRUE.,myThid)
                0404         CALL BAR2( myThid )
                0405 
4d72283393 Mart*0406         _BEGIN_MASTER( myThid )
23a37235f2 Gael*0407          cbuffindex = nwetglobal(k)
                0408         IF ( myProcId .eq. 0 ) THEN
                0409 
                0410 #ifndef ALLOW_ADMTLM
                0411         if ( cbuffindex .gt. 0) then
5cf4364659 Mart*0412           read(cunit) loc_ncbuffindex
                0413           read(cunit) loc_k
                0414           if (loc_ncbuffindex .NE. cbuffindex) then
23a37235f2 Gael*0415             print *, 'WARNING: wrong cbuffindex ',
5cf4364659 Mart*0416      &                 loc_ncbuffindex, cbuffindex
23a37235f2 Gael*0417             STOP 'in S/R ctrl_unpack'
                0418           endif
5cf4364659 Mart*0419           if (loc_k .NE. 1) then
23a37235f2 Gael*0420             print *, 'WARNING: wrong k ',
5cf4364659 Mart*0421      &                 loc_k, 1
f5635c29ac Mart*0422             STOP 'in S/R ctrl_set_unpack_xy'
23a37235f2 Gael*0423           endif
                0424           read(cunit) (cbuff(ii), ii=1,cbuffindex)
                0425         endif
dac57cef35 Patr*0426 #endif
                0427 
23a37235f2 Gael*0428         cbuffindex = 0
                0429         DO j=1,Ny
                0430           DO i=1,Nx
                0431             if (msk2d_buf_glo(i,j) .ne. 0. ) then
                0432                cbuffindex = cbuffindex + 1
                0433                fld2d_buf_glo(i,j) = cbuff(cbuffindex)
                0434             endif
                0435           ENDDO
                0436         ENDDO
                0437 
                0438         ENDIF
4d72283393 Mart*0439         _END_MASTER( myThid )
23a37235f2 Gael*0440         _BARRIER
                0441 
                0442         CALL BAR2( myThid )
                0443         CALL SCATTER_2D_R8( fld2d_buf_glo, fld2d_buf,
                0444      &                       Nx,Ny,.FALSE.,.TRUE.,myThid)
                0445         CALL BAR2( myThid )
                0446         CALL MDS_PASS_R8toRL( fld2d_buf, fld2dNodim,
cf2ce61250 Jean*0447      &                 0, 0, 1, k, 1, 0, 0, .TRUE., myThid )
23a37235f2 Gael*0448 
                0449       enddo !do k = 1, 1
                0450 
                0451 c-- 2.2: normalize field if needed
                0452       DO bj = myByLo(myThid), myByHi(myThid)
                0453        DO bi = myBxLo(myThid), myBxHi(myThid)
                0454          DO j=1,sNy
                0455           DO i=1,sNx
                0456            if (msk3d(i,j,1,bi,bj).EQ.0. _d 0) then
                0457             fld2dDim(i,j,bi,bj)=0. _d 0
                0458             fld2dNodim(i,j,bi,bj)=0. _d 0
                0459            else
                0460 #ifdef ALLOW_ADMTLM
                0461             nveccount = nveccount + 1
                0462             fld2dNodim(i,j,bi,bj)=phtmpadmtlm(nveccount)
cf2ce61250 Jean*0463 #endif
23a37235f2 Gael*0464             if (lxxadxx) then
cf2ce61250 Jean*0465                fld2dDim(i,j,bi,bj) =
3145d51f22 Patr*0466      &              fld2dNodim(i,j,bi,bj) * precondScalar
23a37235f2 Gael*0467             else
                0468                fld2dDim(i,j,bi,bj) =
3145d51f22 Patr*0469      &              fld2dNodim(i,j,bi,bj) / precondScalar
23a37235f2 Gael*0470             endif
                0471            endif
                0472           ENDDO
                0473          ENDDO
                0474        ENDDO
                0475       ENDDO
                0476 
                0477 c-- 2.3:
                0478       if ( doPackDiag ) then
                0479       call WRITE_REC_3D_RL( cfile2, ctrlprec,
4d72283393 Mart*0480      &        1, fld2dNodim, irec, 0, myThid)
23a37235f2 Gael*0481       call WRITE_REC_3D_RL( cfile3, ctrlprec,
4d72283393 Mart*0482      &        1, fld2dDim, irec, 0, myThid)
23a37235f2 Gael*0483       endif
                0484 
cf2ce61250 Jean*0485 c-- 2.4:
                0486       call WRITE_REC_3D_RL( fname, ctrlprec,
4d72283393 Mart*0487      &        1, fld2dDim, irec, 0, myThid)
23a37235f2 Gael*0488 
5cf4364659 Mart*0489       enddo !do irec = 1, ncvarrecs(ivar)
23a37235f2 Gael*0490 
cf2ce61250 Jean*0491 # endif /* ALLOW_PACKUNPACK_METHOD2 */
23a37235f2 Gael*0492 # endif /* EXCLUDE_CTRL_PACK */
                0493 
5d5c0b0d52 Patr*0494       return
                0495       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!