#include "GRDCHK_OPTIONS.h" #ifdef ALLOW_CTRL # include "CTRL_OPTIONS.h" #endif subroutine grdchk_loc( I icomp, I ichknum, O icvrec, O itile, O jtile, O layer, O obcspos, O itilepos, O jtilepos, O icglom1, O itest, O ierr, I mythid & ) c ================================================================== c SUBROUTINE grdchk_loc c ================================================================== c c o Get the location of a given component of the control vector for c the current process. c c started: Christian Eckert eckert@mit.edu 04-Apr-2000 c continued: heimbach@mit.edu: 13-Jun-2001 c c ================================================================== c SUBROUTINE grdchk_loc c ================================================================== implicit none c == global variables == #include "EEPARAMS.h" #include "SIZE.h" #include "GRID.h" #include "ctrl.h" #include "CTRL_OBCS.h" #include "grdchk.h" #ifdef ALLOW_OBCS # include "OBCS_GRID.h" #endif #ifdef ALLOW_SHELFICE # include "SHELFICE.h" #endif /* ALLOW_SHELFICE */ c == routine arguments == integer icomp integer ichknum integer icvrec integer jtile integer itile integer layer integer obcspos integer itilepos integer jtilepos integer itest integer ierr integer mythid #ifdef ALLOW_GRDCHK c == local variables == integer bi,bj integer i,j,k integer itmp,jtmp integer iobcs c integer biwrk,bjwrk integer iwrk, jwrk, kwrk integer iobcswrk integer irec, irecwrk integer icglo, icglom1 integer itlo,ithi integer jtlo,jthi integer jmin,jmax integer imin,imax integer icomptest integer icomploc integer nobcsmax c == end of interface == jtlo = 1 jthi = nsy itlo = 1 ithi = nsx jmin = 1 jmax = sny imin = 1 imax = snx _BEGIN_MASTER( mythid ) c initialise parameters ierr = -5 icglom1 = 0 icomploc= 0 cph( print *, 'ph-test icomp, ncvarcomp, ichknum ', & icomp, ncvarcomp, ichknum cph) if ( icomp .gt. 0 ) then if ( icomp .le. ncvarcomp ) then c-- A valid component of the control variable has been selected. if ( ichknum .EQ. 1 ) then itest = 0 icomptest = 0 irecwrk = 1 c bjwrk = 1 c biwrk = 1 kwrk = 1 iobcswrk = 1 jwrk = 1 iwrk = 1 icglo = 0 else itest = itestmem (ichknum-1) icomptest = icompmem (ichknum-1) irecwrk = irecmem (ichknum-1) c bjwrk = bjmem (ichknum-1) c biwrk = bimem (ichknum-1) kwrk = klocmem (ichknum-1) iobcswrk = iobcsmem (ichknum-1) icglo = icglomem (ichknum-1) jwrk = jlocmem (ichknum-1) iwrk = ilocmem (ichknum-1) iwrk = iwrk + 1 end if c-- set max loop index for obcs multiplicities if ( ncvargrd(grdchkvarindex) .eq. 'm' ) then nobcsmax = nobcs else nobcsmax = 1 endif cph( cph-print print *, 'ph-grd _loc: icomp, ichknum ', cph-print & icomp, ichknum, ncvarcomp cpj) c-- Start to loop over records. do irec = irecwrk, ncvarrecs(grdchkvarindex) cph do iobcs = iobcswrk, nobcsmax iobcs = MOD((irec-1),nobcsmax) + 1 c do bj = bjwrk, jthi c do bi = biwrk, ithi bj = jLocTile bi = iLocTile do k = kwrk, ncvarnrmax(grdchkvarindex) icglo = icglo + nwettile(bi,bj,k,iobcs) icglom1 = icglo - nwettile(bi,bj,k,iobcs) cph( print *, 'ph-grd _loc: bi, bj, icomptest, ichknum ', & bi, bj, icomptest, ichknum cph-print print *, 'ph-grd _loc: icglo ', cph-print & k, icglo, icglom1, iwetsum(bi,bj,k) cpj) if ( (ierr .ne. 0) .and. & (icomp .gt. icglom1 .AND. icomp .LE. icglo) ) then cph cph if ( (ierr .ne. 0) .and. cph & (icomp .gt. cph & (iobcs-1)*iwetsum(bi,bj,nr)+iwetsum(bi,bj,k-1)) cph & .and. cph & (icomp .le. cph & (iobcs-1)*iwetsum(bi,bj,nr)+iwetsum(bi,bj,k))) then cph if ( icomptest .EQ. 0 ) then icomptest = icglom1 endif icomploc = icomp icvrec = irec itile = bi jtile = bj cph( cph-print print *, 'ph-grd irec, bj, bi, k ', irec, bj, bi, k cpj) do j = jwrk, ncvarymax(grdchkvarindex) do i = iwrk, ncvarxmax(grdchkvarindex) if (ierr .ne. 0) then if ( ncvargrd(grdchkvarindex) .eq. 'c' ) then if ( maskC(i,j,k,bi,bj) .gt. 0.) then icomptest = icomptest + 1 itmp = i jtmp = j endif else if ( ncvargrd(grdchkvarindex) .eq. 's' ) then if ( _maskS(i,j,k,bi,bj) .gt. 0.) then icomptest = icomptest + 1 itmp = i jtmp = j endif else if ( ncvargrd(grdchkvarindex) .eq. 'w' ) then if ( _maskW(i,j,k,bi,bj) .gt. 0.) then icomptest = icomptest + 1 itmp = i jtmp = j endif #ifdef ALLOW_SHIFWFLX_CONTROL else if ( ncvargrd(grdchkvarindex) .eq. 'i' ) then if ( maskSHI(i,j,k,bi,bj) .gt. 0.) then icomptest = icomptest + 1 itmp = i jtmp = j endif #endif /* ALLOW_SHIFWFLX_CONTROL */ else if ( ncvargrd(grdchkvarindex) .eq. 'm' ) then if ( grdchkvarindex .EQ. 11 ) then #ifdef ALLOW_OBCSN_CONTROL if ( grdchk_maskxz(i,k,bi,bj,iobcs) .gt. 0. & .and. j.eq. OB_Jn(I,bi,bj) ) then icomptest = icomptest + 1 itmp = i jtmp = OB_Jn(I,bi,bj) endif #endif else if ( grdchkvarindex .EQ. 12 ) then #ifdef ALLOW_OBCSS_CONTROL if ( grdchk_maskxz(i,k,bi,bj,iobcs) .gt. 0. & .and. j.eq. OB_Js(I,bi,bj) ) then icomptest = icomptest + 1 itmp = i jtmp = OB_Js(I,bi,bj) endif #endif else if ( grdchkvarindex .EQ. 13 ) then #ifdef ALLOW_OBCSW_CONTROL if ( grdchk_maskyz(j,k,bi,bj,iobcs) .gt. 0. & .and. i.eq. OB_Iw(J,bi,bj) ) then icomptest = icomptest + 1 itmp = OB_Iw(J,bi,bj) jtmp = j endif #endif else if ( grdchkvarindex .EQ. 14 ) then #ifdef ALLOW_OBCSE_CONTROL if ( grdchk_maskyz(j,k,bi,bj,iobcs) .gt. 0. & .and. i.eq. OB_Ie(J,bi,bj) ) then icomptest = icomptest + 1 itmp = OB_Ie(J,bi,bj) jtmp = j endif #endif endif endif cph( cph-print print *, 'ph-grd icomp, icomptest, icomploc, i, j ', cph-print & icomp, icomptest, icomploc, i, j cpj) if ( icomploc .eq. icomptest ) then itilepos = itmp jtilepos = jtmp layer = k obcspos = iobcs ierr = 0 cph itest = iwetsum(bi,bj,k) cph( print *, 'ph-grd -->hit<-- ', itmp,jtmp,k,iobcs goto 1234 cph) endif endif enddo iwrk = 1 enddo jwrk = 1 else if (ierr .NE. 0) then if (icomptest .EQ. icomp-1) then icomptest = icomptest else icomptest = icomptest + nwettile(bi,bj,k,iobcs) endif cph( cph-print print *, 'ph-grd after loop icomptest, icomploc, k ', cph-print & icomptest, icomploc, k cph) iwrk = 1 jwrk = 1 else c endif c-- End of loop over k enddo kwrk = 1 c-- End of loop over bi c enddo c biwrk = 1 c-- End of loop over bj c enddo c bjwrk = 1 c-- End of loop over iobcs cph enddo cph iobcswrk = 1 c-- End of loop over irec records. enddo c else if ( icomp .gt. maxncvarcomps ) then c-- Such a component does not exist. ierr = -4 icvrec = -1 jtile = -1 itile = -1 layer = -1 obcspos = -1 jtilepos = -1 itilepos = -1 else c-- The component is a land point. ierr = -3 icvrec = -1 jtile = -1 itile = -1 layer = -1 obcspos = -1 jtilepos = -1 itilepos = -1 endif endif else if ( icomp .lt. 0 ) then c-- Such a component does not exist. ierr = -2 icvrec = -1 jtile = -1 itile = -1 layer = -1 obcspos = -1 jtilepos = -1 itilepos = -1 else c-- Component zero. ierr = -1 icvrec = -1 jtile = -1 itile = -1 layer = -1 obcspos = -1 jtilepos = -1 itilepos = -1 endif endif 1234 continue _END_MASTER( mythid ) _BARRIER #endif /* ALLOW_GRDCHK */ return end