Back to home page

MITgcm
 
 

    

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

view on githubraw file Latest commit 5cf43646 on 2024-03-01 18:50:49 UTC
9c7e07a4e1 Jean*0001 #include "GRDCHK_OPTIONS.h"
a7eff9e819 Jean*0002 #ifdef ALLOW_CTRL
                0003 # include "CTRL_OPTIONS.h"
                0004 #endif
f81d465bd0 Patr*0005 
                0006       subroutine grdchk_get_position( mythid )
                0007 
                0008 c     ==================================================================
                0009 c     SUBROUTINE grdchk_loc
                0010 c     ==================================================================
                0011 c
                0012 c     o Get the location of a given component of the control vector for
                0013 c       the current process.
                0014 c
                0015 c     started: Christian Eckert eckert@mit.edu 04-Apr-2000
                0016 c     continued: heimbach@mit.edu: 13-Jun-2001
                0017 c
                0018 c     ==================================================================
                0019 c     SUBROUTINE grdchk_loc
                0020 c     ==================================================================
                0021 
                0022       implicit none
                0023 
                0024 c     == global variables ==
                0025 
                0026 #include "EEPARAMS.h"
                0027 #include "SIZE.h"
                0028 #include "GRID.h"
e6556bc77a Mart*0029 #ifdef ALLOW_SHELFICE
                0030 # include "SHELFICE.h"
9c7e07a4e1 Jean*0031 #endif
c732bd258e Patr*0032 #ifdef ALLOW_OBCS
                0033 # include "OBCS_GRID.h"
                0034 #endif
5cf4364659 Mart*0035 #include "CTRL_SIZE.h"
4d72283393 Mart*0036 #include "CTRL.h"
444da61630 Mart*0037 #ifdef ALLOW_OBCS_CONTROL
                0038 C     CTRL_OBCS.h must be included before GRDCHK.h
                0039 # include "CTRL_OBCS.h"
                0040 #endif
                0041 #include "GRDCHK.h"
f81d465bd0 Patr*0042 
                0043 c     == routine arguments ==
9f5240b52a Jean*0044       integer       mythid
f81d465bd0 Patr*0045 
9f5240b52a Jean*0046 #ifdef ALLOW_GRDCHK
                0047 c     == local variables ==
f81d465bd0 Patr*0048       integer       icvrec
                0049       integer       jtile
                0050       integer       itile
                0051       integer       layer
                0052       integer       obcspos
                0053       integer       itilepos
                0054       integer       jtilepos
                0055       integer       itest
                0056       integer       ierr
                0057       integer bi,bj
                0058       integer i,j,k
                0059       integer iobcs
                0060       integer iwrk, jwrk, kwrk
                0061       integer iobcswrk
                0062       integer irec, irecwrk
                0063       integer itlo,ithi
                0064       integer jtlo,jthi
                0065       integer jmin,jmax
                0066       integer imin,imax
                0067       integer icomptest
                0068       integer nobcsmax
                0069       integer pastit
                0070       _RL wetlocal
                0071 
                0072 c     == end of interface ==
                0073 
                0074       jtlo = 1
                0075       jthi = nsy
                0076       itlo = 1
                0077       ithi = nsx
                0078       jmin = 1
                0079       jmax = sny
                0080       imin = 1
                0081       imax = snx
                0082 
232d1fe37e Jean*0083       itile = iLocTile
                0084       jtile = jLocTile
e4b263335d Patr*0085       itilepos = iGloPos
                0086       jtilepos = jGloPos
f81d465bd0 Patr*0087       layer    = kGloPos
                0088       obcspos  = obcsglo
                0089       icvrec   = recglo
                0090 
e4b263335d Patr*0091       _BEGIN_MASTER( mythid )
                0092 
232d1fe37e Jean*0093 c--   determine proc. number from following assumptions <= done in grdchk_readparms
ef53b829d7 Jean*0094 
f81d465bd0 Patr*0095       if ( myProcId .EQ. grdchkwhichproc ) then
                0096 
                0097 c     initialise parameters
                0098       ierr      = -5
                0099       pastit    = -1
                0100       wetlocal  = 0
                0101 
                0102       itest     = 0
                0103       icomptest = 0
                0104       irecwrk   = 1
232d1fe37e Jean*0105 c     bjwrk     = 1
                0106 c     biwrk     = 1
f81d465bd0 Patr*0107       kwrk      = 1
                0108       iobcswrk  = 1
                0109       jwrk      = 1
                0110       iwrk      = 1
                0111 
                0112 c--   set max loop index for obcs multiplicities
                0113       if ( ncvargrd(grdchkvarindex) .eq. 'm' ) then
444da61630 Mart*0114 #ifdef ALLOW_OBCS_CONTROL
f81d465bd0 Patr*0115          nobcsmax = nobcs
444da61630 Mart*0116 #else
                0117          print *, 'S/R grdchk_get_position: Ooops!'
                0118 #endif
f81d465bd0 Patr*0119       else
                0120          nobcsmax = 1
                0121       endif
                0122 
                0123 c--   Start to loop over records.
                0124         do irec = irecwrk, ncvarrecs(grdchkvarindex)
                0125          iobcs = MOD((irec-1),nobcsmax) + 1
232d1fe37e Jean*0126 c         do bj = bjwrk, jthi
                0127 c          do bi = biwrk, ithi
                0128             bi = itile
                0129             bj = jtile
f81d465bd0 Patr*0130             do k = kwrk, ncvarnrmax(grdchkvarindex)
                0131 
e4b263335d Patr*0132 cph(
                0133 cph-print               print *, 'ph-grd get_pos irec, bj, bi, k ',
ef53b829d7 Jean*0134 cph-print     &              irec, bj, bi, k
e4b263335d Patr*0135 cph)
f81d465bd0 Patr*0136              if ( ierr .ne. 0 ) then
                0137                do j = jwrk, ncvarymax(grdchkvarindex)
                0138                 do i = iwrk, ncvarxmax(grdchkvarindex)
                0139                  if (ierr .ne. 0) then
                0140                   if ( ncvargrd(grdchkvarindex) .eq. 'c' ) then
                0141                      if ( maskC(i,j,k,bi,bj) .gt. 0.) then
                0142                         icomptest = icomptest + 1
                0143                      endif
                0144                      wetlocal = maskC(i,j,k,bi,bj)
                0145                   else if ( ncvargrd(grdchkvarindex) .eq. 's' ) then
                0146                      if ( _maskS(i,j,k,bi,bj) .gt. 0.) then
                0147                         icomptest = icomptest + 1
                0148                      endif
                0149                      wetlocal = _maskS(i,j,k,bi,bj)
                0150                   else if ( ncvargrd(grdchkvarindex) .eq. 'w' ) then
                0151                      if ( _maskW(i,j,k,bi,bj) .gt. 0.) then
                0152                         icomptest = icomptest + 1
                0153                      endif
                0154                      wetlocal = _maskW(i,j,k,bi,bj)
6b47d550f4 Mart*0155 #ifdef ALLOW_SHELFICE
e6556bc77a Mart*0156 c--             Ice shelf mask.
                0157                   else if ( ncvargrd(grdchkvarindex) .eq. 'i' ) then
                0158                      if ( maskSHI(i,j,k,bi,bj) .gt. 0.) then
                0159                         icomptest = icomptest + 1
                0160                      endif
                0161                      wetlocal = maskSHI(i,j,k,bi,bj)
6b47d550f4 Mart*0162 #endif /* ALLOW_SHELFICE */
5cf4364659 Mart*0163 #ifdef ALLOW_OBCS_CONTROL
f81d465bd0 Patr*0164                   else if ( ncvargrd(grdchkvarindex) .eq. 'm' ) then
5cf4364659 Mart*0165                      if ( ncvarfname(grdchkvarindex)
                0166      &                  .eq.xx_obcsn_file ) then
f81d465bd0 Patr*0167 #ifdef ALLOW_OBCSN_CONTROL
c732bd258e Patr*0168                         if (grdchk_maskxz(i,k,bi,bj,iobcs) .gt. 0.
                0169      &                       .and. j.eq. OB_Jn(I,bi,bj) ) then
f81d465bd0 Patr*0170                            icomptest = icomptest + 1
                0171                         endif
                0172                         wetlocal = grdchk_maskxz(i,k,bi,bj,iobcs)
                0173 #endif
5cf4364659 Mart*0174                      else if ( ncvarfname(grdchkvarindex)
                0175      &                       .eq.xx_obcss_file ) then
f81d465bd0 Patr*0176 #ifdef ALLOW_OBCSS_CONTROL
232d1fe37e Jean*0177                         if (grdchk_maskxz(i,k,bi,bj,iobcs) .gt. 0.
c732bd258e Patr*0178      &                       .and. j.eq. OB_Js(I,bi,bj) ) then
f81d465bd0 Patr*0179                            icomptest = icomptest + 1
                0180                         endif
                0181                         wetlocal = grdchk_maskxz(i,k,bi,bj,iobcs)
                0182 #endif
5cf4364659 Mart*0183                      else if ( ncvarfname(grdchkvarindex)
                0184      &                       .eq.xx_obcse_file ) then
                0185 #ifdef ALLOW_OBCSE_CONTROL
                0186                         if (grdchk_maskyz(j,k,bi,bj,iobcs) .gt. 0.
                0187      &                       .and. i.eq. OB_Ie(J,bi,bj) ) then
f81d465bd0 Patr*0188                            icomptest = icomptest + 1
                0189                         endif
                0190                         wetlocal = grdchk_maskyz(j,k,bi,bj,iobcs)
                0191 #endif
5cf4364659 Mart*0192                      else if ( ncvarfname(grdchkvarindex)
                0193      &                       .eq.xx_obcsw_file ) then
                0194 #ifdef ALLOW_OBCSW_CONTROL
                0195                         if ( grdchk_maskyz(j,k,bi,bj,iobcs) .gt. 0.
                0196      &                      .and. i.eq. OB_Iw(J,bi,bj) ) then
f81d465bd0 Patr*0197                            icomptest = icomptest + 1
                0198                         endif
                0199                         wetlocal = grdchk_maskyz(j,k,bi,bj,iobcs)
                0200 #endif
                0201                      endif
5cf4364659 Mart*0202 #endif /* ALLOW_OBCS_CONTROL */
f81d465bd0 Patr*0203                   endif
                0204 c
                0205                   if ( i     .EQ. itilepos .AND.
                0206      &                 j     .EQ. jtilepos .AND.
                0207      &                 k     .EQ. layer .AND.
e4b263335d Patr*0208      &                 bi    .EQ. itile .AND.
                0209      &                 bj    .EQ. jtile .AND.
f81d465bd0 Patr*0210      &                 iobcs .EQ. obcspos .AND.
                0211      &                 irec  .EQ. icvrec ) then
                0212                      pastit = 0
                0213                      if ( wetlocal .NE.0 ) then
                0214                         nbeg = icomptest
                0215                         nend = nbeg + nend
                0216                         ierr     = 0
                0217                         print '(a,6I5)',
                0218      &                       ' grad-res exact position met: '
ef53b829d7 Jean*0219                         print '(a,7I5)',
f81d465bd0 Patr*0220      &                       ' grad-res ', grdchkwhichproc,
                0221      &                       nbeg, itilepos, jtilepos, layer,
27067cb768 Patr*0222      &                       itile, jtile
e4b263335d Patr*0223                         goto 1234
f81d465bd0 Patr*0224                      endif
ef53b829d7 Jean*0225                   else if ( pastit .EQ. 0 .AND.
f81d465bd0 Patr*0226      &                    wetlocal .NE.0 ) then
                0227                      nbeg = icomptest
                0228                      nend = nbeg + nend
                0229                      ierr     = 0
                0230                         print '(a,6I5)',
                0231      &                       ' grad-res closest next position: '
ef53b829d7 Jean*0232                         print '(a,7I5)',
f81d465bd0 Patr*0233      &                       ' grad-res ', grdchkwhichproc,
                0234      &                       nbeg, itilepos, jtilepos, layer,
27067cb768 Patr*0235      &                       itile, jtile
e4b263335d Patr*0236                         goto 1234
f81d465bd0 Patr*0237                   endif
                0238 c
                0239                  endif
                0240                 enddo
                0241                 iwrk = 1
                0242                enddo
                0243                jwrk = 1
                0244              else if (ierr .NE. 0) then
                0245                 itest     = itest + nwettile(bi,bj,k,iobcs)
                0246                 iwrk      = 1
                0247                 jwrk      = 1
                0248              endif
                0249 c--   End of loop over k
                0250             enddo
                0251             kwrk = 1
                0252 c--   End of loop over bi
232d1fe37e Jean*0253 c          enddo
                0254 c          biwrk = 1
f81d465bd0 Patr*0255 c--   End of loop over bj
232d1fe37e Jean*0256 c         enddo
                0257 c         bjwrk = 1
f81d465bd0 Patr*0258 c--   End of loop over iobcs
                0259 cph         enddo
                0260 cph         iobcswrk = 1
                0261 c--   End of loop over irec records.
                0262          enddo
                0263 
                0264 c--   End of if myProcId statement
                0265       endif
                0266 
e4b263335d Patr*0267  1234 continue
                0268 
f81d465bd0 Patr*0269       _END_MASTER( mythid )
                0270 
                0271       _BARRIER
                0272 
                0273 #endif /* ALLOW_GRDCHK */
                0274 
9c7e07a4e1 Jean*0275       return
f81d465bd0 Patr*0276       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!