! !----------------------------------------------------------------------- ! ! auxillary routines that involve off-processor communication. ! shared memory version, contained in module mod_xc. ! ! author: Alan J. Wallcraft, NRL. ! !----------------------------------------------------------------------- ! subroutine xcaget(aa, a, mnflg) implicit none ! real, intent(out) :: aa(itdm,jtdm) real, intent(in) :: a(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) integer, intent(in) :: mnflg ! !********** !* ! 1) convert an entire 2-D array from tiled to non-tiled layout. ! ! 3) mnflg selects which nodes must return the array ! = 0; all nodes ! = n; node number n (mnproc=n) ! ! 4) parameters: ! name type usage description ! ---------- ---------- ------- ---------------------------- ! aa real output non-tiled target array ! a real input tiled source array ! mnflg integer input node return flag !* !********** ! integer j #if defined(TIMER) ! ! call xctmr0( 1) #endif ! ! use xclget for now. ! do j= 1,jtdm call xclget(aa(1,j),itdm, a, 1,j,1,0, mnflg) enddo #if defined(TIMER) ! ! call xctmr1( 1) #endif return end subroutine xcaget subroutine xcaput(aa, a, mnflg) implicit none ! real, intent(inout) :: aa(itdm,jtdm) real, intent(out) :: a(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) integer, intent(in) :: mnflg ! !********** !* ! 1) convert an entire 2-D array from non-tiled to tiled layout. ! ! 3) mnflg selects which nodes must contain the non-tiled array ! = 0; all nodes ! = n; node number n (mnproc=n) ! ! 4) parameters: ! name type usage description ! ---------- ---------- ------- ---------------------------- ! aa real input non-tiled source array ! a real output tiled target array ! mnflg integer input node source flag !* !********** ! integer j #if defined(TIMER) ! ! call xctmr0( 4) #endif ! ! use xclput for now. ! do j= 1,jtdm call xclput(aa(1,j),itdm, a, 1,j,1,0) enddo #if defined(TIMER) ! ! call xctmr1( 4) #endif return end subroutine xcaput subroutine xcastr(a, mnflg) implicit none ! real, intent(inout) :: a(:) integer, intent(in) :: mnflg ! !********** !* ! 1) broadcast array a to all tiles. ! ! 3) parameters: ! name type usage description ! ---------- ---------- ------- ---------------------------- ! a real in/out target array ! mnflg integer input node originator flag !* !********** ! #if defined(TIMER) ! call xctmr0( 9) #endif ! ! single node version - do nothing. #if defined(TIMER) ! call xctmr1( 9) #endif return end subroutine xcastr subroutine xceget(aelem, a, ia,ja, mnflg) implicit none ! real, intent(out) :: aelem real, intent(in) :: a(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) integer, intent(in) :: ia,ja integer, intent(in), optional :: mnflg ! !********** !* ! 1) find the value of a(ia,ja) on the non-tiled 2-D grid. ! ! 2) mnflg selects which nodes must return the line ! = 0; all nodes (default) ! = n; node number n (mnproc=n) ! mnflg is ignored here (only have a single node). ! ! 3) parameters: ! name type usage description ! ---------- ---------- ------- ---------------------------- ! aelem real output required element ! a real input source array ! ia integer input 1st index into a ! ja integer input 2nd index into a ! mnflg integer input node return flag !* !********** #if defined(TIMER) ! call xctmr0( 2) #endif ! ! single node version - trivial indexing. ! aelem = a(ia,ja) #if defined(TIMER) ! call xctmr1( 2) #endif return end subroutine xceget subroutine xceput(aelem, a, ia,ja, mnflg) implicit none ! integer, intent(in), optional :: mnflg integer, intent(in) :: ia,ja real, intent(in) :: aelem real, intent(inout) :: a(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) ! !********** !* ! 1) fill a single element in the non-tiled 2-D grid. ! ! 2) mnflg selects which nodes hold the element on entry ! = 0; all nodes (default) ! = n; node number n (mnproc=n) ! mnflg is ignored here (only have a single node). ! ! 3) parameters: ! name type usage description ! ---------- ---------- ------- ---------------------------- ! aelem real input element value ! a real in/out target array ! ia integer input 1st index into a ! ja integer input 2nd index into a ! mnflg integer input node source flag !* !********** #if defined(TIMER) ! call xctmr0( 4) #endif ! ! single node version - trivial indexing. ! a(ia,ja) = aelem #if defined(TIMER) ! call xctmr1( 4) #endif return end subroutine xceput subroutine xchalt(cerror) implicit none ! character*(*), intent(in) :: cerror ! !********** !* ! 1) stop all processes. ! ! 2) only one processes need call this routine, i.e. it is for ! emergency stops. use 'xcstop' for ordinary stops called ! by all processes. ! ! 3) parameters: ! name type usage description ! ---------- ---------- ------- ---------------------------- ! cerror char*(*) input error message !* !********** ! ! shared memory version, just stop. ! if (cerror.ne.' ') then write(lp,*) '**************************************************' write(lp,*) cerror write(lp,*) '**************************************************' call flush(lp) endif stop '(xchalt)' end subroutine xchalt subroutine xciget(alist,nl, a, ia,ja, mnflg) implicit none ! integer, intent(in) :: nl real, intent(out) :: alist(nl) real, intent(in) :: a(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) integer, intent(in) :: ia(nl),ja(nl) integer, intent(in), optional :: mnflg ! !********** !* ! 1) find the value of a(ia(:),ja(:)) on the non-tiled 2-D grid. ! ! 2) mnflg selects which nodes must return the list of elements ! = 0; all nodes (default) ! = n; node number n (mnproc=n) ! mnflg is ignored here (only have a single node). ! ! 3) parameters: ! name type usage description ! ---------- ---------- ------- ---------------------------- ! alist real output required elements ! nl integer input dimension of alist ! a real input source array ! ia integer input 1st indexes into a ! ja integer input 2nd indexes into a ! mnflg integer input node return flag !* !********** ! integer i ! #if defined(TIMER) ! call xctmr0( 2) #endif ! ! single node version - trivial indexing. ! do i= 1,nl alist(i) = a(ia(i),ja(i)) enddo !i #if defined(TIMER) ! call xctmr1( 2) #endif return end subroutine xciget subroutine xciget_sm(alist,nl, a, ia,ja, mnflg) implicit none ! integer, intent(in) :: nl real, intent(out) :: alist(nl) real, intent(in) :: a(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) integer, intent(in) :: ia(nl),ja(nl) integer, intent(in), optional :: mnflg ! !********** !* ! 1) find the value of a(ia(:),ja(:)) on the non-tiled 2-D grid. ! identical to xciget and never invoked (for compatibility only) ! ! 2) mnflg selects which nodes must return the list of elements ! = 0; all nodes (default) ! = n; node number n (mnproc=n) ! mnflg is ignored here (only have a single node). ! ! 3) parameters: ! name type usage description ! ---------- ---------- ------- ---------------------------- ! alist real output required elements ! nl integer input dimension of alist ! a real input source array ! ia integer input 1st indexes into a ! ja integer input 2nd indexes into a ! mnflg integer input node return flag !* !********** ! integer i ! #if defined(TIMER) ! call xctmr0( 2) #endif ! ! single node version - trivial indexing. ! do i= 1,nl alist(i) = a(ia(i),ja(i)) enddo !i #if defined(TIMER) ! call xctmr1( 2) #endif return end subroutine xciget_sm subroutine xciput(alist,nl, a, ia,ja, mnflg) implicit none ! integer, intent(in) :: nl integer, intent(in), optional :: mnflg integer, intent(in) :: ia(nl),ja(nl) real, intent(inout) :: alist(nl) real, intent(inout) :: a(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) ! !********** !* ! 1) fill a list of elements in the non-tiled 2-D grid. ! ! 2) mnflg selects which nodes hold the elements on entry ! = 0; all nodes (default) ! = n; node number n (mnproc=n) ! mnflg is ignored here (only have a single node). ! ! 3) parameters: ! name type usage description ! ---------- ---------- ------- ---------------------------- ! alist real in/out element values ! nl integer input dimension of alist ! a real in/out target array ! ia integer input 1st indexes into a ! ja integer input 2nd indexes into a ! mnflg integer input node source flag !* !********** ! integer i #if defined(TIMER) ! call xctmr0( 4) #endif ! ! single node version - trivial indexing. ! do i= 1,nl a(ia(i),ja(i)) = alist(i) enddo !1 #if defined(TIMER) ! call xctmr1( 4) #endif return end subroutine xciput subroutine xclget(aline,nl, a, i1,j1,iinc,jinc, mnflg) implicit none ! integer, intent(in) :: nl,i1,j1,iinc,jinc,mnflg real, intent(out) :: aline(nl) real, intent(in) :: a(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) ! !********** !* ! 1) extract a line of elements from the non-tiled 2-D grid. ! ! 2) aline(i) = a(i1+iinc*(i-1),j1+jinc*(i-1)), for i=1...nl. ! iinc and jinc can each be -1, 0, or +1. ! ! if jinc=0, j1 can be between jtdm+1 and jtdm+nbdy to return ! values from the top halo. This is for debugging the arctic ! patch halo exchange only. ! ! 3) mnflg selects which nodes must return the line ! =-n; node number n (mnproc=n), nl,i1,j1 only on node n ! = 0; all nodes ! = n; node number n (mnproc=n) ! normally all integer arguments must be identical on all nodes, ! but a negative mnflg indicates that only the target node is ! providing the nl,i1,j1 values. These are broadcast to all other ! nodes, and returned in nl,i1,j1 by all of them. ! ! mnflg is ignored here (only have a single node). ! ! 4) parameters: ! name type usage description ! ---------- ---------- ------- ---------------------------- ! aline real output required line of elements ! nl integer in/out dimension of aline ! a real input source array ! i1 integer in/out 1st index into a ! j1 integer in/out 2nd index into a ! iinc integer input 1st index increment ! jinc integer input 2nd index increment ! mnflg integer input node return flag ! ! nl,i1,j1 are input only unless mnflg is negative. !* !********** ! integer i #if defined(TIMER) ! call xctmr0( 3) #endif ! ! single node version - trivial indexing and no error checking. ! if (jinc.eq.0) then do i= 1,nl aline(i) = a(i1+iinc*(i-1),j1) enddo elseif (iinc.eq.0) then do i= 1,nl aline(i) = a(i1,j1+jinc*(i-1)) enddo else do i= 1,nl aline(i) = a(i1+iinc*(i-1),j1+jinc*(i-1)) enddo endif #if defined(TIMER) ! call xctmr1( 3) #endif return end subroutine xclget subroutine xclput(aline,nl, a, i1,j1,iinc,jinc, mnflg) implicit none ! integer, intent(in), optional :: mnflg integer, intent(in) :: nl,i1,j1,iinc,jinc real, intent(inout) :: aline(nl) real, intent(inout) :: a(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) ! !********** !* ! 1) fill a line of elements in the non-tiled 2-D grid. ! ! 2) aline(i) = a(i1+i1*(i-1),j1+j1*(i-1)), for i=1...nl. ! one of iinc and jinc must be 0, and the other must be 1. ! ! 3) mnflg selects which nodes hold the line on entry ! = 0; all nodes (default) ! = n; node number n (mnproc=n) ! mnflg is ignored here (only have a single node). ! ! 4) parameters: ! name type usage description ! ---------- ---------- ------- ---------------------------- ! aline real in/out line of element values ! nl integer input dimension of aline ! a real in/out target array ! i1 integer input 1st index into a ! j1 integer input 2nd index into a ! iinc integer input 1st index increment ! jinc integer input 2nd index increment ! mnflg integer input node source flag !* !********** ! integer i #if defined(TIMER) ! call xctmr0( 4) #endif ! ! single node version - trivial indexing. ! if (jinc.eq.0) then do i= 1,nl a(i1+i-1,j1) = aline(i) enddo elseif (iinc.eq.0) then do i= 1,nl a(i1,j1+i-1) = aline(i) enddo endif #if defined(TIMER) ! call xctmr1( 4) #endif return end subroutine xclput subroutine xcmaxr_0(a, mnflg) implicit none ! real, intent(inout) :: a integer, intent(in) :: mnflg ! !********** !* ! 1) replace scalar a with its element-wise maximum over all tiles. ! ! 2) mnflg selects which nodes must return the minimum ! = 0; all nodes ! = n; node number n (mnproc=n) ! ! 3) parameters: ! name type usage description ! ---------- ---------- ------- ---------------------------- ! a real in/out target variable ! mnflg integer input node return flag !* !********** ! #if defined(TIMER) ! call xctmr0(10) #endif ! ! single node version - do nothing. #if defined(TIMER) ! call xctmr1(10) #endif return end subroutine xcmaxr_0 subroutine xcmaxr_1(a, mnflg) implicit none ! real, intent(inout) :: a(:) integer, intent(in) :: mnflg ! !********** !* ! 1) replace array a with its element-wise maximum over all tiles. ! ! 2) mnflg selects which nodes must return the minimum ! = 0; all nodes ! = n; node number n (mnproc=n) ! ! 3) parameters: ! name type usage description ! ---------- ---------- ------- ---------------------------- ! a real in/out target array ! mnflg integer input node return flag !* !********** ! #if defined(TIMER) ! call xctmr0(10) #endif ! ! single node version - do nothing. #if defined(TIMER) ! call xctmr1(10) #endif return end subroutine xcmaxr_1 subroutine xcmaxr_0o(a) implicit none ! real, intent(inout) :: a ! !********** !* ! 1) replace scalar a with its element-wise maximum over all tiles. ! ! 2) parameters: ! name type usage description ! ---------- ---------- ------- ---------------------------- ! a real in/out target variable !* !********** ! #if defined(TIMER) ! call xctmr0(10) #endif ! ! single node version - do nothing. #if defined(TIMER) ! call xctmr1(10) #endif return end subroutine xcmaxr_0o subroutine xcmaxr_1o(a) implicit none ! real, intent(inout) :: a(:) ! !********** !* ! 1) replace array a with its element-wise maximum over all tiles. ! ! 2) parameters: ! name type usage description ! ---------- ---------- ------- ---------------------------- ! a real in/out target array !* !********** ! #if defined(TIMER) ! call xctmr0(10) #endif ! ! single node version - do nothing. #if defined(TIMER) ! call xctmr1(10) #endif return end subroutine xcmaxr_1o subroutine xcminr_0(a, mnflg) implicit none ! real, intent(inout) :: a integer, intent(in) :: mnflg ! !********** !* ! 1) replace scalar a with its element-wise minimum over all tiles. ! ! 2) mnflg selects which nodes must return the minimum ! = 0; all nodes ! = n; node number n (mnproc=n) ! ! 3) parameters: ! name type usage description ! ---------- ---------- ------- ---------------------------- ! a real in/out target variable ! mnflg integer input node return flag !* !********** ! #if defined(TIMER) ! call xctmr0(10) #endif ! ! single node version - do nothing. #if defined(TIMER) ! call xctmr1(10) #endif return end subroutine xcminr_0 subroutine xcminr_1(a, mnflg) implicit none ! real, intent(inout) :: a(:) integer, intent(in) :: mnflg ! !********** !* ! 1) replace array a with its element-wise minimum over all tiles. ! ! 2) mnflg selects which nodes must return the minimum ! = 0; all nodes ! = n; node number n (mnproc=n) ! ! 3) parameters: ! name type usage description ! ---------- ---------- ------- ---------------------------- ! a real in/out target array ! mnflg integer input node return flag !* !********** ! #if defined(TIMER) ! call xctmr0(10) #endif ! ! single node version - do nothing. #if defined(TIMER) ! call xctmr1(10) #endif return end subroutine xcminr_1 subroutine xcminr_0o(a) implicit none ! real, intent(inout) :: a ! !********** !* ! 1) replace scalar a with its element-wise minimum over all tiles. ! ! 2) parameters: ! name type usage description ! ---------- ---------- ------- ---------------------------- ! a real in/out target variable !* !********** ! #if defined(TIMER) ! call xctmr0(10) #endif ! ! single node version - do nothing. #if defined(TIMER) ! call xctmr1(10) #endif return end subroutine xcminr_0o subroutine xcminr_1o(a) implicit none ! real, intent(inout) :: a(:) ! !********** !* ! 1) replace array a with its element-wise minimum over all tiles. ! ! 2) parameters: ! name type usage description ! ---------- ---------- ------- ---------------------------- ! a real in/out target array !* !********** ! #if defined(TIMER) ! call xctmr0(10) #endif ! ! single node version - do nothing. #if defined(TIMER) ! call xctmr1(10) #endif return end subroutine xcminr_1o subroutine xcspmd implicit none ! !********** !* ! 1) initialize data structures that identify the tiles. ! ! 2) data structures: ! ipr - 1st 2-D node dimension ! jpr - 2nd 2-D node dimension ! ijpr - 1-D node dimension (ipr*jpr) ! mproc - 1st 2-D node index ! nproc - 2nd 2-D node index ! mnproc - 1-D node index ! i0 - 1st dimension tile offset ! ii - 1st dimension tile extent ! j0 - 2nd dimension tile offset ! jj - 2nd dimension tile extent ! nreg - region type ! vland - fill value for land (standard value 0.0) ! ! 3) ipr,jpr,ijpr are global (tile independent) values. ! all other values depend on the processor number, ! but in this case there is only one processor. !* !********** ! ! shared memory version, mproc=nproc=1. ! if (iqr.ne.1 .or. jqr.ne.1 .or. ijqr.ne.1) then call xcstop('Error in xcspmd: must have iqr=jqr=ijqr=1') stop '(xcspmd)' endif ! lp = 6 ! ipr = 1 jpr = 1 ijpr = 1 mnproc = 1 mproc = 1 nproc = 1 ! #if defined(RELO) ! --- region's horizontal dimensions are from blkdat.input. ! itdm = -1 jtdm = -1 #endif ! i0 = 0 ii = itdm j0 = 0 jj = jtdm ! nreg = -1 ! unknown region type ! vland = 0.0 vland4 = 0.0 ! ! initialize timers. ! call xctmri #if defined(TIMER) call xctmrn( 1,'xcaget') call xctmrn( 2,'xceget') call xctmrn( 3,'xclget') call xctmrn( 4,'xcXput') call xctmrn( 5,'xcsum ') call xctmrn( 6,'xcrang') call xctmrn( 9,'xcastr') call xctmrn(10,'xcmaxr') call xctmrn(12,'xctilr') #if defined(ARCTIC) call xctmrn(13,'xctila') #endif #endif return end subroutine xcspmd subroutine xcstop(cerror) implicit none ! character*(*), intent(in) :: cerror ! !********** !* ! 1) stop all processes. ! ! 2) all processes must call this routine. ! use 'xchalt' for emergency stops. ! ! 3) parameters: ! name type usage description ! ---------- ---------- ------- ---------------------------- ! cerror char*(*) input error message !* !********** ! ! print active timers. ! call xctmrp ! ! shared memory version, just stop. ! if (cerror.ne.' ') then write(lp,*) '**************************************************' write(lp,*) cerror write(lp,*) '**************************************************' call flush(lp) endif #if defined(STOP2003) ! --- Fortran 2003 STOP outputs many lines, replace with exit call exit(0) #else stop '(xcstop)' #endif end subroutine xcstop subroutine xcsum(sum, a,mask) implicit none ! real*8, intent(out) :: sum real, intent(inout) :: a( 1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) integer, intent(in) :: mask(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) ! !********** !* ! 1) sum a 2-d array, where mask==1 ! ! 2) parameters: ! name type usage description ! ---------- ---------- ------- ---------------------------- ! sum real*8 output sum of a ! a real input source array ! mask integer input mask array ! ! 3) sum is bit for bit reproducable for the same halo size, nbdy. !* !********** ! real*8 zero8 parameter (zero8=0.0) ! real*8 sum8,sum8p,sum8j(jdm) integer i,i1,j #if defined(TIMER) ! call xctmr0( 5) #endif ! ! row sums in 2*nbdy+1 wide strips. ! !$OMP PARALLEL DO PRIVATE(j,i1,i,sum8,sum8p) & !$OMP SCHEDULE(STATIC,jblk) do j=1,jdm sum8 = zero8 do i1=1,idm,2*nbdy+1 sum8p = zero8 do i= i1,min(i1+2*nbdy,idm) if (mask(i,j).eq.1) then sum8p = sum8p + a(i,j) endif enddo sum8 = sum8 + sum8p enddo sum8j(j) = sum8 ! use of sum8 minimizes false sharing of sum8j enddo !$OMP END PARALLEL DO ! ! serial sum of rwo-sum loop. ! sum8 = sum8j(1) do j=2,jdm sum8 = sum8 + sum8j(j) enddo sum = sum8 #if defined(TIMER) ! call xctmr1( 5) #endif return end subroutine xcsum subroutine xcsumj(sumj, a,mask) implicit none ! real*8, intent(out) :: sumj(jtdm) real, intent(inout) :: a( 1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) integer, intent(in) :: mask(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) ! !********** !* ! 1) rwo-sum of a 2-d array, where mask==1, on first processor only ! ! 2) parameters: ! name type usage description ! ---------- ---------- ------- ---------------------------- ! sumj real*8 output row-sum of a ! a real input source array ! mask integer input mask array ! ! 3) sum is bit for bit reproducable for the same halo size, nbdy. !* !********** ! real*8 zero8 parameter (zero8=0.0) ! real*8 sum8,sum8p integer i,i1,j #if defined(TIMER) ! call xctmr0( 5) #endif ! ! row sums in 2*nbdy+1 wide strips. ! !$OMP PARALLEL DO PRIVATE(j,i1,i,sum8,sum8p) & !$OMP SCHEDULE(STATIC,jblk) do j=1,jdm sum8 = zero8 do i1=1,idm,2*nbdy+1 sum8p = zero8 do i= i1,min(i1+2*nbdy,idm) if (mask(i,j).eq.1) then sum8p = sum8p + a(i,j) endif enddo sum8 = sum8 + sum8p enddo sumj(j) = sum8 ! use of sum8 minimizes false sharing of sumj enddo !$OMP END PARALLEL DO #if defined(TIMER) ! call xctmr1( 5) #endif return end subroutine xcsumj subroutine xcsumr_0(a, mnflg) implicit none ! real, intent(inout) :: a integer, intent(in) :: mnflg ! !********** !* ! 1) replace scalar a with its element-wise sum over all tiles. ! ! 2) mnflg selects which nodes must return the sum ! = 0; all nodes ! = n; node number n (mnproc=n) ! ! 3) parameters: ! name type usage description ! ---------- ---------- ------- ---------------------------- ! a real in/out target variable ! mnflg integer input node return flag !* !********** ! #if defined(TIMER) ! call xctmr0(10) #endif ! ! single node version - do nothing. #if defined(TIMER) ! call xctmr1(10) #endif return end subroutine xcsumr_0 subroutine xcsumr_1(a, mnflg) implicit none ! real, intent(inout) :: a(:) integer, intent(in) :: mnflg ! !********** !* ! 1) replace array a with its element-wise sum over all tiles. ! ! 2) mnflg selects which nodes must return the sum ! = 0; all nodes ! = n; node number n (mnproc=n) ! ! 3) parameters: ! name type usage description ! ---------- ---------- ------- ---------------------------- ! a real in/out target array ! mnflg integer input node return flag !* !********** ! #if defined(TIMER) ! call xctmr0(10) #endif ! ! single node version - do nothing. #if defined(TIMER) ! call xctmr1(10) #endif return end subroutine xcsumr_1 subroutine xcsync(lflush) implicit none ! logical, intent(in) :: lflush ! !********** !* ! 1) barrier, no processor exits until all arrive (and flush stdout). ! ! 2) some MPI implementations only flush stdout as a collective ! operation, and hence the lflush=.true. option to flush stdout. ! ! 3) Only one processor, so the barrier is a no-op in this case. !* !********** ! if (lflush) then call flush(lp) endif return end subroutine xcsync #if defined(ARCTIC) subroutine xctila(a,l1,ld,itype) implicit none ! integer, intent(in) :: l1,ld,itype real, intent(inout) :: a(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,ld) ! !********** !* ! 1) update the top row of a real array. ! only needed when importing a tripole grid array. ! ! 2) parameters: ! name type usage description ! ---------- ---------- ------- ---------------------------- ! a real in/out target array ! l1 integer input 3rd dim. start index ! ld integer input 3rd dimension of a ! itype integer input grid and field type ! ! 3) itype selects both the grid and field type ! itype= 1; p-grid, scalar field ! itype=11; p-grid, vector field ! ! 4) this version for a global tripole (arctic bipolar patch) grid !* !********** ! integer i,io,k #if defined(TIMER) ! call xctmr0(13) #endif do k= l1,ld if (itype.eq.1) then ! ! scalar on p-grid ! do i= 1,ii io = ii-mod(i-1,ii) a(i,jj,k) = a(io,jj-1,k) enddo else ! ! vector p-grid field, swap sign ! do i= 1,ii io = ii-mod(i-1,ii) a(i,jj,k) = -a(io,jj-1,k) enddo endif enddo #if defined(TIMER) ! call xctmr1(13) #endif return end subroutine xctila subroutine xctilr(a,l1,ld,mh,nh,itype) implicit none ! integer, intent(in) :: l1,ld,mh,nh,itype real, intent(inout) :: a(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,ld) ! !********** !* ! 1) update the tile overlap halo of a real array. ! ! 2) parameters: ! name type usage description ! ---------- ---------- ------- ---------------------------- ! a real in/out target array ! l1 integer input 3rd dim. start index ! ld integer input 3rd dimension of a ! mh integer input 1st (EW) update halo size ! nh integer input 2nd (NS) update halo size ! itype integer input grid and field type ! ! 3) itype selects both the grid and field type ! itype= 1; p-grid, scalar field ! itype= 2; q-grid, scalar field ! itype= 3; u-grid, scalar field ! itype= 4; v-grid, scalar field ! itype=11; p-grid, vector field ! itype=12; q-grid, vector field ! itype=13; u-grid, vector field ! itype=14; v-grid, vector field ! ! 4) this version for a global grid that includes the arctic ocean !* !********** ! integer i,io,j,k,mhl,nhl #if defined(TIMER) ! call xctmr0(12) #endif ! mhl = max(0,min(mh,nbdy)) nhl = max(0,min(nh,nbdy)) ! if (nhl.gt.0) then do k= l1,ld ! ! southern boundary is closed. ! do j= 1,nhl do i= 1,ii a(i,1-j,k) = vland enddo enddo ! if (itype.lt.10) then ! ! scalar field ! if (itype.eq. 1) then ! ! p-grid ! do j= 1,nhl do i= 1,ii io = ii-mod(i-1,ii) a(i,jj+j,k) = a(io,jj-1-j,k) enddo enddo elseif (itype.eq. 2) then ! ! q-grid ! do j= 1,nhl do i= 1,ii io = mod(ii-(i-1),ii)+1 a(i,jj+j,k) = a(io,jj-j,k) enddo enddo elseif (itype.eq. 3) then ! ! u-grid ! do j= 1,nhl do i= 1,ii io = mod(ii-(i-1),ii)+1 a(i,jj+j,k) = a(io,jj-1-j,k) enddo enddo else ! ! v-grid ! do j= 1,nhl do i= 1,ii io = ii-mod(i-1,ii) a(i,jj+j,k) = a(io,jj-j,k) enddo enddo endif else ! ! vector field, swap sign ! if (itype.eq.11) then ! ! p-grid ! do j= 1,nhl do i= 1,ii io = ii-mod(i-1,ii) a(i,jj+j,k) = -a(io,jj-1-j,k) enddo enddo elseif (itype.eq.12) then ! ! q-grid ! do j= 1,nhl do i= 1,ii io = mod(ii-(i-1),ii)+1 a(i,jj+j,k) = -a(io,jj-j,k) enddo enddo elseif (itype.eq.13) then ! ! u-grid ! do j= 1,nhl do i= 1,ii io = mod(ii-(i-1),ii)+1 a(i,jj+j,k) = -a(io,jj-1-j,k) enddo enddo else ! ! v-grid ! do j= 1,nhl do i= 1,ii io = ii-mod(i-1,ii) a(i,jj+j,k) = -a(io,jj-j,k) enddo enddo endif endif enddo endif ! if (mhl.gt.0) then do k= 1,ld do j= 1-nhl,jj+nhl do i= 1,mhl a( 1-i,j,k) = a(ii+1-i,j,k) a(ii+i,j,k) = a( i,j,k) enddo enddo enddo endif #if defined(TIMER) ! call xctmr1(12) #endif return end subroutine xctilr #else /* !ARCTIC */ subroutine xctilr(a,l1,ld,mh,nh,itype) implicit none ! integer, intent(in) :: l1,ld,mh,nh,itype real, intent(inout) :: a(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,ld) ! !********** !* ! 1) update the tile overlap halo of a real array. ! ! 2) parameters: ! name type usage description ! ---------- ---------- ------- ---------------------------- ! a real in/out target array ! l1 integer input 3rd dim. start index ! ld integer input 3rd dimension of a ! mh integer input 1st (EW) update halo size ! nh integer input 2nd (NS) update halo size ! itype integer input grid and field type ! ! 3) itype selects both the grid and field type ! itype= 1; p-grid, scalar field ! itype= 2; q-grid, scalar field ! itype= 3; u-grid, scalar field ! itype= 4; v-grid, scalar field ! itype=11; p-grid, vector field ! itype=12; q-grid, vector field ! itype=13; u-grid, vector field ! itype=14; v-grid, vector field ! it is ignored here because all types are the same unless ! the grid includes the arctic ocean !* !********** ! integer i,j,k,mhl,nhl #if defined(TIMER) ! call xctmr0(12) #endif ! mhl = max(0,min(mh,nbdy)) nhl = max(0,min(nh,nbdy)) ! if (nhl.gt.0) then if (nreg.le.2) then ! closed in latitude do k= l1,ld do j= 1,nhl do i= 1,ii a(i, 1-j,k) = vland a(i,jj+j,k) = vland enddo enddo enddo else ! periodic (f-plane) in latitude do k= l1,ld do j= 1,nhl do i= 1,ii a(i, 1-j,k) = a(i,jj+1-j,k) a(i,jj+j,k) = a(i, j,k) enddo enddo enddo endif endif ! if (mhl.gt.0) then if (nreg.eq.0 .or. nreg.eq.4) then ! closed in longitude do k= l1,ld do j= 1-nhl,jj+nhl do i= 1,mhl a( 1-i,j,k) = vland a(ii+i,j,k) = vland enddo enddo enddo else ! periodic in longitude do k= l1,ld do j= 1-nhl,jj+nhl do i= 1,mhl a( 1-i,j,k) = a(ii+1-i,j,k) a(ii+i,j,k) = a( i,j,k) enddo enddo enddo endif endif #if defined(TIMER) ! call xctmr1(12) #endif return end subroutine xctilr #endif /* ARCTIC:else */ subroutine xctmri implicit none ! !********** !* ! 1) initialize timers. ! ! 2) timers 1:32 are for message passing routines, ! timers 33:80 are for general hycom routines, ! timers 81:96 are for user selected routines. ! timer 97 is the total time. ! ! 3) call xctmri to initialize timers (called in xcspmd), ! call xctmr0(n) to start timer n, ! call xctmr1(n) to stop timer n and add event to timer sum, ! call xctnrn(n,cname) to register a name for timer n, ! call xctmrp to printout timer statistics (called by xcstop). !* !********** ! integer i ! real*8 zero8 parameter (zero8=0.0) ! do 110 i= 1,97 cc(i) = ' ' nc(i) = 0 tc(i) = zero8 110 continue ! call xctmrn(97,'total ') call xctmr0(97) return end subroutine xctmri subroutine xctmr0(n) implicit none ! integer, intent(in) :: n ! !********** !* ! 1) start timer n. ! ! 2) parameters: ! name type usage description ! ---------- ---------- ------- ---------------------------- ! n integer input timer number ! ! 3) time every 50-th event above 5,000. !* !********** ! real*8 wtime ! #if defined(DEBUG_TIMER) if (n.gt.24 .and. cc(n).ne.' ') then write(lp,*) 'call ',cc(n) call flush(lp) endif #endif if (timer_on) then if (mod(nc(n),50).eq.0 .or. nc(n).le.5000) then t0(n) = wtime() endif endif !timer_on return end subroutine xctmr0 subroutine xctmr1(n) implicit none ! integer, intent(in) :: n ! !********** !* ! 1) add time since call to xctim0 to timer n. ! ! 2) parameters: ! name type usage description ! ---------- ---------- ------- ---------------------------- ! n integer input timer number ! ! 3) time every 50-th event above 5,000. !* !********** ! real*8 wtime ! if (timer_on) then if (nc(n).gt.5000) then if (mod(nc(n),50).eq.0) then tc(n) = tc(n) + 50.0*(wtime() - t0(n)) endif else tc(n) = tc(n) + (wtime() - t0(n)) endif nc(n) = nc(n) + 1 endif !timer_on #if defined(DEBUG_TIMER) if (n.gt.24 .and. cc(n).ne.' ') then write(lp,*) 'exit ',cc(n) call flush(lp) endif #endif return end subroutine xctmr1 subroutine xctmrn(n,cname) implicit none ! character*6, intent(in) :: cname integer, intent(in) :: n ! !********** !* ! 1) register name of timer n. ! ! 2) parameters: ! name type usage description ! ---------- ---------- ------- ---------------------------- ! n integer input timer number ! cname char*(8) input timer name !* !********** ! cc(n) = cname return end subroutine xctmrn subroutine xctmrp implicit none ! !********** !* ! 1) print all active timers. ! ! 2) on exit all timers are reset to zero. !* !********** ! real*8 tci integer i ! real*8 zero8 parameter (zero8=0.0) ! ! get total time. ! call xctmr1(97) ! ! print timers. ! write(lp,6000) do i= 1,97 if (nc(i).ne.0) then if (nc(i).le.5000) then tci = tc(i) else !correct for timing every 50th event tci = (tc(i)*nc(i))/(nc(i)-mod(nc(i),50)) endif if (cc(i).ne.' ') then write(lp,6100) cc(i),nc(i),tci,tci/nc(i) else write(lp,6150) i, nc(i),tci,tci/nc(i) endif endif enddo write(lp,6200) call flush(lp) ! ! reset timers to zero. ! do i= 1,97 nc(i) = 0 tc(i) = zero8 enddo ! ! start a new total time measurement. ! call xctmr0(97) return ! 6000 format(/ / & 4x,' timer statistics ' / & 4x,'------------------' /) 6100 format(5x,a6, & ' calls =',i9, & ' time =',f11.5, & ' time/call =',f14.8) 6150 format(5x,' #',i2, & ' calls =',i9, & ' time =',f11.5, & ' time/call =',f14.8) 6200 format(/ /) end subroutine xctmrp ! ! Revision history: ! !> Nov. 2011 - time every 50-th event above 5,000 (was 1,000). !> Mar. 2012 - added optional mnflg to xclput !> Apr. 2012 - added optional mnflg to xceget and xceput !> Apr. 2012 - added xciget and xciput !> Oct. 2019 - added xcsumr