Warning, /eesupp/src/exch1_z_rx_cube.template is written in an unsupported language. File is not indexed.
view on githubraw file Latest commit aa6b2555 on 2021-06-06 02:50:10 UTC
ba0dad37f4 Jean*0001 #include "CPP_EEOPTIONS.h"
0002
0003 CBOP
0004
0005 C !ROUTINE: EXCH1_Z_RX_CUBE
0006
0007 C !INTERFACE:
0008 SUBROUTINE EXCH1_Z_RX_CUBE(
0009 U array,
0010 I withSigns,
0011 I myOLw, myOLe, myOLs, myOLn, myNz,
0012 I exchWidthX, exchWidthY,
0013 I cornerMode, myThid )
0014
0015 C !DESCRIPTION:
aa6b2555c8 Jean*0016 C *==============================================================*
ba0dad37f4 Jean*0017 C | SUBROUTINE EXCH1_Z_RX_CUBE
0018 C | o Forward-mode edge exchanges for RX array on CS config:
0019 C | Fill overlap region through tile exchanges,
0020 C | according to CS topology,
0021 C | for a Zeta-located, scalar field RX arrays.
aa6b2555c8 Jean*0022 C *==============================================================*
ba0dad37f4 Jean*0023 C | Controlling routine for exchange of XY edges of an array
aa6b2555c8 Jean*0024 C | distributed in X and Y.
0025 C | This is a preliminary (exch1), simpler version with few
0026 C | limitations (no MPI, 1 tile per face, regular 6 squared faces,
0027 C | multi-threads only on shared arrays, i.e., in commom block)
0028 C | that are fixed in generalised pkg/exch2 implementation.
0029 C | Notes:
0030 C | zeta coord exchange operation for cube sphere grid
0031 C *==============================================================*
ba0dad37f4 Jean*0032
0033 C !USES:
0034 IMPLICIT NONE
0035
0036 C == Global data ==
0037 #include "SIZE.h"
0038 #include "EEPARAMS.h"
0039
0040 C !INPUT/OUTPUT PARAMETERS:
0041 C == Routine arguments ==
0042 C array :: Array with edges to exchange.
0043 C withSigns :: Flag controlling whether field sign depends on orientation
0044 C :: (signOption not yet implemented but needed for SM exch)
0045 C myOLw,myOLe :: West and East overlap region sizes.
0046 C myOLs,myOLn :: South and North overlap region sizes.
0047 C exchWidthX :: Width of data region exchanged in X.
0048 C exchWidthY :: Width of data region exchanged in Y.
0049 C Note --
0050 C 1. In theory one could have a send width and
0051 C a receive width for each face of each tile. The only
0052 C restriction would be that the send width of one
0053 C face should equal the receive width of the sent to
0054 C tile face. Dont know if this would be useful. I
0055 C have left it out for now as it requires additional
0056 C bookeeping.
0057 C cornerMode :: Flag indicating whether corner updates are needed.
0058 C myThid :: my Thread Id number
0059
0060 INTEGER myOLw, myOLe, myOLs, myOLn, myNz
0061 _RX array( 1-myOLw:sNx+myOLe,
0062 & 1-myOLs:sNy+myOLn,
0063 & myNz, nSx, nSy )
0064 LOGICAL withSigns
0065 INTEGER exchWidthX
0066 INTEGER exchWidthY
0067 INTEGER cornerMode
0068 INTEGER myThid
0069
0070 C !LOCAL VARIABLES:
0071 C == Local variables ==
0072 C theSimulationMode :: Holds working copy of simulation mode
0073 C theCornerMode :: Holds working copy of corner mode
0074 C I,J,K,repeat :: Loop counters and index
0075 C bl,bt,bn,bs,be,bw :: tile indices
0076 c INTEGER theSimulationMode
0077 c INTEGER theCornerMode
0078 INTEGER I,J,K,repeat
0079 INTEGER bl,bt,bn,bs,be,bw
0080 CHARACTER*(MAX_LEN_MBUF) msgBuf
0081
0082 C == Statement function ==
0083 INTEGER tilemod
0084 tilemod(I)=1+mod(I-1+6,6)
0085 CEOP
0086
0087 c theSimulationMode = FORWARD_SIMULATION
0088 c theCornerMode = cornerMode
0089
0090 c IF ( simulationMode.EQ.REVERSE_SIMULATION ) THEN
0091 c WRITE(msgBuf,'(A)')'EXCH1_Z_RX_CUBE: AD mode not implemented'
0092 c CALL PRINT_ERROR( msgBuf, myThid )
0093 c STOP 'ABNORMAL END: EXCH1_Z_RX_CUBE: no AD code'
0094 c ENDIF
0095 IF ( sNx.NE.sNy .OR.
0096 & nSx.NE.6 .OR. nSy.NE.1 .OR.
0097 & nPx.NE.1 .OR. nPy.NE.1 ) THEN
0098 WRITE(msgBuf,'(2A)') 'EXCH1_Z_RX_CUBE: Wrong Tiling'
0099 CALL PRINT_ERROR( msgBuf, myThid )
0100 WRITE(msgBuf,'(2A)') 'EXCH1_Z_RX_CUBE: ',
0101 & 'works only with sNx=sNy & nSx=6 & nSy=nPx=nPy=1'
0102 CALL PRINT_ERROR( msgBuf, myThid )
0103 STOP 'ABNORMAL END: EXCH1_Z_RX_CUBE: Wrong Tiling'
0104 ENDIF
0105
0106 C For now tile<->tile exchanges are sequentialised through
0107 C thread 1. This is a temporary feature for preliminary testing until
0108 C general tile decomposistion is in place (CNH April 11, 2001)
0109 CALL BAR2( myThid )
0110 IF ( myThid .EQ. 1 ) THEN
0111
0112 DO repeat=1,2
0113
0114 DO bl = 1, 5, 2
0115
0116 bt = bl
0117 bn=tilemod(bt+2)
0118 bs=tilemod(bt-1)
0119 be=tilemod(bt+1)
0120 bw=tilemod(bt-2)
0121
0122 DO K = 1, myNz
0123 DO J = 1, sNy+1
0124 DO I = 0, exchWidthX-1
0125
0126 C Tile Odd:Odd+2 [get] [North<-West]
0127 array(J,sNy+I+1,K,bt,1) = array(I+1,sNy+2-J,K,bn,1)
0128 C Tile Odd:Odd+1 [get] [East<-West]
0129 array(sNx+I+1,J,K,bt,1) = array(I+1,J,K,be,1)
0130
0131 cs- these above loop should really have the same range the lower one
0132 ENDDO
0133 DO I = 1, exchWidthX-0
0134 cs- but this replaces the missing I/O routines for now
0135
0136 C Tile Odd:Odd-1 [get] [South<-North]
0137 array(J,1-I,K,bt,1) = array(J,sNy+1-I,K,bs,1)
0138 C Tile Odd:Odd-2 [get] [West<-North]
0139 array(1-I,J,K,bt,1) = array(sNx+2-J,sNy+1-I,K,bw,1)
0140
0141 ENDDO
0142 ENDDO
0143 ENDDO
0144
0145 bt = bl+1
0146 bn=tilemod(bt+1)
0147 bs=tilemod(bt-2)
0148 be=tilemod(bt+2)
0149 bw=tilemod(bt-1)
0150
0151 DO K = 1, myNz
0152 DO J = 1, sNy+1
0153 DO I = 0, exchWidthX-1
0154
0155 C Tile Even:Even+1 [get] [North<-South]
0156 array(J,sNy+I+1,K,bt,1) = array(J,I+1,K,bn,1)
0157 C Tile Even:Even+2 [get] [East<-South]
0158 array(sNx+I+1,J,K,bt,1) = array(sNx+2-J,I+1,K,be,1)
0159
0160 cs- these above loop should really have the same range the lower one
0161 ENDDO
0162 DO I = 1, exchWidthX-0
0163 cs- but this replaces the missing I/O routines for now
0164
0165 C Tile Even:Even-2 [get] [South<-East]
0166 array(J,1-I,K,bt,1) = array(sNx+1-I,sNy+2-J,K,bs,1)
0167 C Tile Even:Even-1 [get] [West<-East]
0168 array(1-I,J,K,bt,1) = array(sNx+1-I,J,K,bw,1)
0169
0170 ENDDO
0171 ENDDO
0172 ENDDO
0173
0174 ENDDO
0175
0176 ENDDO
0177
0178 ENDIF
0179 CALL BAR2(myThid)
0180
0181 RETURN
0182 END
