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
0009
0010
0011
0012
0013
0014
0015
0016
0017
0018
0019
0020
0021
0022 implicit none
0023
0024
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
0039 # include "CTRL_OBCS.h"
0040 #endif
0041 #include "GRDCHK.h"
f81d465bd0 Patr*0042
0043
9f5240b52a Jean*0044 integer mythid
f81d465bd0 Patr*0045
9f5240b52a Jean*0046 #ifdef ALLOW_GRDCHK
0047
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
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
ef53b829d7 Jean*0094
f81d465bd0 Patr*0095 if ( myProcId .EQ. grdchkwhichproc ) then
0096
0097
0098 ierr = -5
0099 pastit = -1
0100 wetlocal = 0
0101
0102 itest = 0
0103 icomptest = 0
0104 irecwrk = 1
232d1fe37e Jean*0105
0106
f81d465bd0 Patr*0107 kwrk = 1
0108 iobcswrk = 1
0109 jwrk = 1
0110 iwrk = 1
0111
0112
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
0124 do irec = irecwrk, ncvarrecs(grdchkvarindex)
0125 iobcs = MOD((irec-1),nobcsmax) + 1
232d1fe37e Jean*0126
0127
0128 bi = itile
0129 bj = jtile
f81d465bd0 Patr*0130 do k = kwrk, ncvarnrmax(grdchkvarindex)
0131
e4b263335d Patr*0132
0133
ef53b829d7 Jean*0134
e4b263335d Patr*0135
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
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
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
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
0250 enddo
0251 kwrk = 1
0252
232d1fe37e Jean*0253
0254
f81d465bd0 Patr*0255
232d1fe37e Jean*0256
0257
f81d465bd0 Patr*0258
0259
0260
0261
0262 enddo
0263
0264
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