--- MITgcm/pkg/exch2/exch2_send_rx2.template 2004/01/09 20:46:09 1.1 +++ MITgcm/pkg/exch2/exch2_send_rx2.template 2008/08/05 18:31:55 1.8 @@ -1,12 +1,16 @@ -#include "CPP_OPTIONS.h" +C $Header: /home/ubuntu/mnt/e9_copy/MITgcm/pkg/exch2/exch2_send_rx2.template,v 1.8 2008/08/05 18:31:55 cnh Exp $ +C $Name: $ + +#include "CPP_EEOPTIONS.h" +#include "W2_OPTIONS.h" SUBROUTINE EXCH2_SEND_RX2 ( - I tIlo, tIhi, tiStride, - I tJlo, tJhi, tjStride, + I tIlo1, tIhi1, tIlo2, tIhi2, tiStride, + I tJlo1, tJhi1, tJlo2, tJhi2, tjStride, I tKlo, tKhi, tkStride, - I thisTile, nN, - I e2Bufr1_RX, e2BufrRecSize, - I e2Bufr2_RX, + I thisTile, nN, oIs1, oJs1, oIs2, oJs2, + O e2Bufr1_RX, e2Bufr2_RX, + I e2BufrRecSize, I array1, I i1Lo, i1Hi, j1Lo, j1Hi, k1Lo, k1Hi, I array2, @@ -20,22 +24,20 @@ IMPLICIT NONE -C -#include "W2_OPTIONS.h" +#include "SIZE.h" +#include "EEPARAMS.h" +#include "EESUPPORT.h" #include "W2_EXCH2_TOPOLOGY.h" -#define W2_USE_E2_SAFEMODE -#include "EEPARAMS.h" - CHARACTER*(MAX_LEN_MBUF) messageBuffer -C C === Routine arguments === - INTEGER tILo, tIHi, tiStride - INTEGER tJLo, tJHi, tjStride - INTEGER tKLo, tKHi, tkStride + INTEGER tIlo1, tIhi1, tIlo2, tIhi2, tiStride + INTEGER tJlo1, tJhi1, tJlo2, tJhi2, tjStride + INTEGER tKlo, tKhi, tkStride INTEGER i1Lo, i1Hi, j1Lo, j1Hi, k1Lo, k1Hi INTEGER i2Lo, i2Hi, j2Lo, j2Hi, k2Lo, k2Hi INTEGER thisTile, nN - INTEGER e2BufrRecSize + INTEGER oIs1, oJs1, oIs2, oJs2 + INTEGER e2BufrRecSize _RX e2Bufr1_RX( e2BufrRecSize ) _RX e2Bufr2_RX( e2BufrRecSize ) _RX array1(i1Lo:i1Hi,j1Lo:j1Hi,k1Lo:k1Hi) @@ -53,42 +55,41 @@ C :: isl etc... source local C :: isc etc... source canonical INTEGER itl, jtl, ktl - INTEGER itc, jtc, ktc - INTEGER isc, jsc, ksc - INTEGER isl, jsl, ksl + INTEGER itc, jtc + INTEGER isc, jsc + INTEGER isl, jsl C tt :: Target tile C itb, jtb :: Target local to canonical offsets C INTEGER tt INTEGER itb, jtb INTEGER isb, jsb - INTEGER pi(2), pj(2), oi, oj, oi_c, oi_f, oj_c, oj_f + INTEGER pi(2), pj(2) _RX sa1, sa2, val1, val2 INTEGER iBufr1, iBufr2 - INTEGER itlreduce - INTEGER jtlreduce C MPI setup -#include "SIZE.h" -#include "EESUPPORT.h" +#ifdef ALLOW_USE_MPI INTEGER theTag1, theTag2, theType, theHandle1, theHandle2 INTEGER sProc, tProc, mpiRc +#endif + CHARACTER*(MAX_LEN_MBUF) messageBuffer IF ( commSetting .EQ. 'P' ) THEN -C Need to check that buffer synchronisation token is decremented +C Need to check that buffer synchronisation token is decremented C before filling buffer. This is needed for parallel processing C shared memory modes only. ENDIF tt=exch2_neighbourId(nN, thisTile ) - itb=exch2_tbasex(tt) - jtb=exch2_tbasey(tt) - isb=exch2_tbasex(thisTile) - jsb=exch2_tbasey(thisTile) - pi(1)=exch2_pi(1,nN,thisTile) - pi(2)=exch2_pi(2,nN,thisTile) - pj(1)=exch2_pj(1,nN,thisTile) - pj(2)=exch2_pj(2,nN,thisTile) + itb=exch2_tBasex(tt) + jtb=exch2_tBasey(tt) + isb=exch2_tBasex(thisTile) + jsb=exch2_tBasey(thisTile) + pi(1)=exch2_pij(1,nN,thisTile) + pi(2)=exch2_pij(2,nN,thisTile) + pj(1)=exch2_pij(3,nN,thisTile) + pj(2)=exch2_pij(4,nN,thisTile) C Extract into bufr1 (target i-index array) C if pi(1) is 1 then +i in target <=> +i in source so bufr1 should get +array1 @@ -101,75 +102,64 @@ sa1 = ABS(sa1) sa2 = ABS(sa2) ENDIF - oi_c=exch2_oi(nN,thisTile) - oi_f=exch2_oi_f(nN,thisTile) - oi=oi_c - oj_c=exch2_oj(nN,thisTile) - oj_f=exch2_oj_f(nN,thisTile) - oj=oj_c C if pi(1) is 1 then +i in source aligns with +i in target C if pj(1) is 1 then +i in source aligns with +j in target - itlreduce=0 - jtlreduce=0 - IF ( pi(1) .EQ. -1 ) THEN - oi=oi_f - itlreduce=1 - ENDIF - IF ( pj(1) .EQ. -1 ) THEN - oj=oj_f - itlreduce=1 - ENDIF iBufr1=0 #ifdef W2_E2_DEBUG_ON - WRITE(messageBuffer,'(A,I4,A,I4)') 'EXCH2_SEND_RX2 sourceTile= ', + WRITE(messageBuffer,'(A,I4,A,I4)') 'EXCH2_SEND_RX2 sourceTile= ', & thisTile, & ' targetTile= ',tt CALL PRINT_MESSAGE(messageBuffer, I standardMessageUnit,SQUEEZE_BOTH, I myThid) #endif /* W2_E2_DEBUG_ON */ - DO ktl=tKlo,tKhi,tKStride - DO jtl=tJLo+jtlreduce, tJHi, tjStride - DO itl=tILo+itlreduce, tIHi, tiStride -C DO jtl=1,32,31 -C DO itl=1,32,31 + DO ktl=tKlo,tKhi,tkStride + DO jtl=tJlo1, tJhi1, tjStride + DO itl=tIlo1, tIhi1, tiStride iBufr1=iBufr1+1 itc=itl+itb jtc=jtl+jtb - isc=pi(1)*itc+pi(2)*jtc+oi - jsc=pj(1)*itc+pj(2)*jtc+oj + isc=pi(1)*itc+pi(2)*jtc+oIs1 + jsc=pj(1)*itc+pj(2)*jtc+oJs1 isl=isc-isb jsl=jsc-jsb val1=sa1*array1(isl,jsl,ktl) & +sa2*array2(isl,jsl,ktl) e2Bufr1_RX(iBufr1)=val1 #ifdef W2_E2_DEBUG_ON - WRITE(messageBuffer,'(A,2I4)') 'EXCH2_SEND_RX2 target u(itl, jtl) = ', itl, jtl + WRITE(messageBuffer,'(A,2I4)') + & 'EXCH2_SEND_RX2 target u(itl, jtl) = ', itl, jtl CALL PRINT_MESSAGE(messageBuffer, I standardMessageUnit,SQUEEZE_RIGHT, I myThid) IF ( pi(1) .EQ. 1 ) THEN C i index aligns - WRITE(messageBuffer,'(A,2I4)') ' source +u(isl, jsl) = ', isl, jsl + WRITE(messageBuffer,'(A,2I4)') + & ' source +u(isl, jsl) = ', isl, jsl ELSEIF ( pi(1) .EQ. -1 ) THEN C reversed i index aligns - WRITE(messageBuffer,'(A,2I4)') ' source -u(isl, jsl) = ', isl, jsl + WRITE(messageBuffer,'(A,2I4)') + & ' source -u(isl, jsl) = ', isl, jsl ELSEIF ( pj(1) .EQ. 1 ) THEN - WRITE(messageBuffer,'(A,2I4)') ' source +v(isl, jsl) = ', isl, jsl + WRITE(messageBuffer,'(A,2I4)') + & ' source +v(isl, jsl) = ', isl, jsl ELSEIF ( pj(1) .EQ. -1 ) THEN - WRITE(messageBuffer,'(A,2I4)') ' source -v(isl, jsl) = ', isl, jsl + WRITE(messageBuffer,'(A,2I4)') + & ' source -v(isl, jsl) = ', isl, jsl ENDIF CALL PRINT_MESSAGE(messageBuffer, I standardMessageUnit,SQUEEZE_RIGHT, I myThid) IF ( isl .LT. i1Lo .OR. isl .GT. i1Hi ) THEN - WRITE(messageBuffer,'(A,2I4)') ' *** isl is out of bounds ' + WRITE(messageBuffer,'(A,2I4)') + & ' *** isl is out of bounds ' CALL PRINT_MESSAGE(messageBuffer, I standardMessageUnit,SQUEEZE_RIGHT, I myThid) ENDIF IF ( jsl .LT. j1Lo .OR. jsl .GT. j1Hi ) THEN - WRITE(messageBuffer,'(A,2I4)') ' *** jsl is out of bounds ' + WRITE(messageBuffer,'(A,2I4)') + & ' *** jsl is out of bounds ' CALL PRINT_MESSAGE(messageBuffer, I standardMessageUnit,SQUEEZE_RIGHT, I myThid) @@ -183,12 +173,12 @@ IF ( isl .LT. i1Lo .OR. isl .GT. i1Hi ) THEN C Forward mode send getting from points outside of the C tiles exclusive domain bounds in X. This should not happen - WRITE(messageBuffer,'(A,I4,I4)') - & 'EXCH2_SEND_RX2 tIlo, tIhi =', tIlo, tIhi + WRITE(messageBuffer,'(A,I4,I4)') + & 'EXCH2_SEND_RX2 tIlo1,tIhi1=', tIlo1, tIhi1 CALL PRINT_MESSAGE(messageBuffer, I standardMessageUnit,SQUEEZE_BOTH, I myThid) - WRITE(messageBuffer,'(A,3I4)') + WRITE(messageBuffer,'(A,3I4)') & 'EXCH2_SEND_RX2 itl, jtl, isl =', itl, jtl, isl CALL PRINT_MESSAGE(messageBuffer, I standardMessageUnit,SQUEEZE_BOTH, @@ -198,18 +188,18 @@ IF ( jsl .LT. j1Lo .OR. jsl .GT. j1Hi ) THEN C Forward mode send getting from points outside of the C tiles exclusive domain bounds in Y. This should not happen - WRITE(messageBuffer,'(A,I4,I4)') - & 'EXCH2_SEND_RX2 tJlo, tJhi =', tJlo, tJhi + WRITE(messageBuffer,'(A,I4,I4)') + & 'EXCH2_SEND_RX2 tJlo1,tJhi1=', tJlo1, tJhi1 CALL PRINT_MESSAGE(messageBuffer, I standardMessageUnit,SQUEEZE_BOTH, I myThid) - WRITE(messageBuffer,'(A,2I4)') + WRITE(messageBuffer,'(A,2I4)') & 'EXCH2_SEND_RX2 itl, jtl =', itl, jtl CALL PRINT_MESSAGE(messageBuffer, I standardMessageUnit,SQUEEZE_BOTH, I myThid) - WRITE(messageBuffer,'(A,2I4)') - & 'EXCH2_SEND_RX2 isl, jsl =', isl, jsl + WRITE(messageBuffer,'(A,2I4)') + & 'EXCH2_SEND_RX2 isl, jsl =', isl, jsl CALL PRINT_MESSAGE(messageBuffer, I standardMessageUnit,SQUEEZE_BOTH, I myThid) @@ -232,75 +222,62 @@ sa1 = ABS(sa1) sa2 = ABS(sa2) ENDIF - oi_c=exch2_oi(nN,thisTile) - oi_f=exch2_oi_f(nN,thisTile) - oi=oi_c - oj_c=exch2_oj(nN,thisTile) - oj_f=exch2_oj_f(nN,thisTile) - oj=oj_c -C if pi(2) is 1 then +i in source aligns with +j in target -C if pj(2) is 1 then +j in source aligns with +j in target - itlreduce=0 - jtlreduce=0 - IF ( pi(2) .EQ. -1 ) THEN - jtlreduce=1 - oi=oi_f - ENDIF - IF ( pj(2) .EQ. -1 ) THEN - jtlreduce=1 - oj=oj_f - ENDIF iBufr2=0 #ifdef W2_E2_DEBUG_ON - WRITE(messageBuffer,'(A,I4,A,I4)') 'EXCH2_SEND_RX2 sourceTile= ', + WRITE(messageBuffer,'(A,I4,A,I4)') 'EXCH2_SEND_RX2 sourceTile= ', & thisTile, & ' targetTile= ',tt CALL PRINT_MESSAGE(messageBuffer, I standardMessageUnit,SQUEEZE_BOTH, I myThid) #endif /* W2_E2_DEBUG_ON */ - DO ktl=tKlo,tKhi,tKStride - DO jtl=tJLo+jtlreduce, tJHi, tjStride - DO itl=tILo+itlreduce, tIHi, tiStride -C DO jtl=1,32,31 -C DO itl=1,32,31 + DO ktl=tKlo,tKhi,tkStride + DO jtl=tJlo2, tJhi2, tjStride + DO itl=tIlo2, tIhi2, tiStride iBufr2=iBufr2+1 itc=itl+itb jtc=jtl+jtb - isc=pi(1)*itc+pi(2)*jtc+oi - jsc=pj(1)*itc+pj(2)*jtc+oj + isc=pi(1)*itc+pi(2)*jtc+oIs2 + jsc=pj(1)*itc+pj(2)*jtc+oJs2 isl=isc-isb jsl=jsc-jsb val2=sa1*array1(isl,jsl,ktl) & +sa2*array2(isl,jsl,ktl) e2Bufr2_RX(iBufr2)=val2 #ifdef W2_E2_DEBUG_ON - WRITE(messageBuffer,'(A,2I4)') 'EXCH2_SEND_RX2 target v(itl, jtl) = ', itl, jtl + WRITE(messageBuffer,'(A,2I4)') + & 'EXCH2_SEND_RX2 target v(itl, jtl) = ', itl, jtl CALL PRINT_MESSAGE(messageBuffer, I standardMessageUnit,SQUEEZE_RIGHT, I myThid) IF ( pi(2) .EQ. 1 ) THEN C i index aligns - WRITE(messageBuffer,'(A,2I4)') ' source +u(isl, jsl) = ', isl, jsl + WRITE(messageBuffer,'(A,2I4)') + & ' source +u(isl, jsl) = ', isl, jsl ELSEIF ( pi(2) .EQ. -1 ) THEN C reversed i index aligns - WRITE(messageBuffer,'(A,2I4)') ' source -u(isl, jsl) = ', isl, jsl + WRITE(messageBuffer,'(A,2I4)') + & ' source -u(isl, jsl) = ', isl, jsl ELSEIF ( pj(2) .EQ. 1 ) THEN - WRITE(messageBuffer,'(A,2I4)') ' source +v(isl, jsl) = ', isl, jsl + WRITE(messageBuffer,'(A,2I4)') + & ' source +v(isl, jsl) = ', isl, jsl ELSEIF ( pj(2) .EQ. -1 ) THEN - WRITE(messageBuffer,'(A,2I4)') ' source -v(isl, jsl) = ', isl, jsl + WRITE(messageBuffer,'(A,2I4)') + & ' source -v(isl, jsl) = ', isl, jsl ENDIF CALL PRINT_MESSAGE(messageBuffer, I standardMessageUnit,SQUEEZE_RIGHT, I myThid) IF ( isl .LT. i1Lo .OR. isl .GT. i1Hi ) THEN - WRITE(messageBuffer,'(A,2I4)') ' *** isl is out of bounds ' + WRITE(messageBuffer,'(A,2I4)') + & ' *** isl is out of bounds ' CALL PRINT_MESSAGE(messageBuffer, I standardMessageUnit,SQUEEZE_RIGHT, I myThid) ENDIF IF ( jsl .LT. j1Lo .OR. jsl .GT. j1Hi ) THEN - WRITE(messageBuffer,'(A,2I4)') ' *** jsl is out of bounds ' + WRITE(messageBuffer,'(A,2I4)') + & ' *** jsl is out of bounds ' CALL PRINT_MESSAGE(messageBuffer, I standardMessageUnit,SQUEEZE_RIGHT, I myThid) @@ -315,12 +292,12 @@ IF ( isl .LT. i1Lo .OR. isl .GT. i1Hi ) THEN C Forward mode send getting from points outside of the C tiles exclusive domain bounds in X. This should not happen - WRITE(messageBuffer,'(A,I4,I4)') - & 'EXCH2_SEND_RX2 tIlo, tIhi =', tIlo, tIhi + WRITE(messageBuffer,'(A,I4,I4)') + & 'EXCH2_SEND_RX2 tIlo2,tIhi2=', tIlo2, tIhi2 CALL PRINT_MESSAGE(messageBuffer, I standardMessageUnit,SQUEEZE_BOTH, I myThid) - WRITE(messageBuffer,'(A,3I4)') + WRITE(messageBuffer,'(A,3I4)') & 'EXCH2_SEND_RX2 itl, jtl, isl =', itl, jtl, isl CALL PRINT_MESSAGE(messageBuffer, I standardMessageUnit,SQUEEZE_BOTH, @@ -330,18 +307,18 @@ IF ( jsl .LT. j1Lo .OR. jsl .GT. j1Hi ) THEN C Forward mode send getting from points outside of the C tiles exclusive domain bounds in Y. This should not happen - WRITE(messageBuffer,'(A,I4,I4)') - & 'EXCH2_SEND_RX2 tJlo, tJhi =', tJlo, tJhi + WRITE(messageBuffer,'(A,I4,I4)') + & 'EXCH2_SEND_RX2 tJlo2,tJhi2=', tJlo2, tJhi2 CALL PRINT_MESSAGE(messageBuffer, I standardMessageUnit,SQUEEZE_BOTH, I myThid) - WRITE(messageBuffer,'(A,2I4)') + WRITE(messageBuffer,'(A,2I4)') & 'EXCH2_SEND_RX2 itl, jtl =', itl, jtl CALL PRINT_MESSAGE(messageBuffer, I standardMessageUnit,SQUEEZE_BOTH, I myThid) - WRITE(messageBuffer,'(A,2I4)') - & 'EXCH2_SEND_RX2 isl, jsl =', isl, jsl + WRITE(messageBuffer,'(A,2I4)') + & 'EXCH2_SEND_RX2 isl, jsl =', isl, jsl CALL PRINT_MESSAGE(messageBuffer, I standardMessageUnit,SQUEEZE_BOTH, I myThid) @@ -355,25 +332,19 @@ C Do data transport depending on communication mechanism between source and target tile IF ( commSetting .EQ. 'P' ) THEN -C Need to set data ready assertion (increment buffer -C synchronisation token) for multithreaded mode, for now do +C Need to set data ready assertion (increment buffer +C synchronisation token) for multithreaded mode, for now do C nothing i.e. assume only one thread per process. ELSEIF ( commSetting .EQ. 'M' ) THEN #ifdef ALLOW_USE_MPI C Setup MPI stuff here theTag1 = (thisTile-1)*MAX_NEIGHBOURS*2 + nN-1 - & + 10000*( - & (tt-1)*MAX_NEIGHBOURS*2 + nN-1 - & ) theTag2 = (thisTile-1)*MAX_NEIGHBOURS*2 + MAX_NEIGHBOURS + nN-1 - & + 10000*( - & (tt-1)*MAX_NEIGHBOURS*2 + MAX_NEIGHBOURS + nN-1 - & ) tProc = exch2_tProc(tt)-1 sProc = exch2_tProc(thisTile)-1 theType = MPI_REAL8 #ifdef W2_E2_DEBUG_ON - WRITE(messageBuffer,'(A,I4,A,I4,A)') ' SEND FROM TILE=', thisTile, + WRITE(messageBuffer,'(A,I4,A,I4,A)') ' SEND FROM TILE=',thisTile, & ' (proc = ',sProc,')' CALL PRINT_MESSAGE(messageBuffer, I standardMessageUnit,SQUEEZE_RIGHT, @@ -401,10 +372,10 @@ I myThid) #endif /* W2_E2_DEBUG_ON */ CALL MPI_Isend( e2Bufr1_RX, iBufr1, theType, - I tProc, theTag1, MPI_COMM_MODEL, + I tProc, theTag1, MPI_COMM_MODEL, O theHandle1, mpiRc ) CALL MPI_Isend( e2Bufr2_RX, iBufr2, theType, - I tProc, theTag2, MPI_COMM_MODEL, + I tProc, theTag2, MPI_COMM_MODEL, O theHandle2, mpiRc ) C Store MPI_Wait token in messageHandle. e2_msgHandle1(1) = theHandle1 @@ -413,6 +384,12 @@ ELSE STOP 'EXCH2_SEND_RX2:: commSetting VALUE IS INVALID' ENDIF - + RETURN END + +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| + +CEH3 ;;; Local Variables: *** +CEH3 ;;; mode:fortran *** +CEH3 ;;; End: ***