| [3331] | 1 | SUBROUTINE SUECRADI |
|---|
| 2 | |
|---|
| 3 | !**** *SUECRADI* - INITIALIZE DATA STRUCTURES FOR RADIATION INTERPOLATION |
|---|
| 4 | |
|---|
| 5 | ! PURPOSE. |
|---|
| 6 | ! -------- |
|---|
| 7 | ! INITIALIZE DATA STRUCTURES FOR RADIATION INTERPOLATION |
|---|
| 8 | |
|---|
| 9 | !** INTERFACE. |
|---|
| 10 | ! ---------- |
|---|
| 11 | ! CALL *SUECRADI* FROM *SUECRAD* |
|---|
| 12 | ! -------- ------- |
|---|
| 13 | |
|---|
| 14 | ! EXPLICIT ARGUMENTS : |
|---|
| 15 | ! -------------------- |
|---|
| 16 | ! NONE |
|---|
| 17 | |
|---|
| 18 | ! IMPLICIT ARGUMENTS : |
|---|
| 19 | ! -------------------- |
|---|
| 20 | |
|---|
| 21 | ! METHOD. |
|---|
| 22 | ! ------- |
|---|
| 23 | ! SEE DOCUMENTATION |
|---|
| 24 | |
|---|
| 25 | ! EXTERNALS. |
|---|
| 26 | ! ---------- |
|---|
| 27 | ! NONE |
|---|
| 28 | |
|---|
| 29 | ! REFERENCE. |
|---|
| 30 | ! ---------- |
|---|
| 31 | ! ECMWF Research Department documentation of the IFS |
|---|
| 32 | |
|---|
| 33 | ! AUTHOR. |
|---|
| 34 | ! ------- |
|---|
| 35 | ! GEORGE MOZDZYNSKI 95-03-13 |
|---|
| 36 | |
|---|
| 37 | ! MODIFICATIONS. |
|---|
| 38 | ! -------------- |
|---|
| 39 | ! 980317: JJMorcrette clean-up (NRAD, NFLUX) |
|---|
| 40 | ! 990907: JJMorcrette clean-up RRTM |
|---|
| 41 | ! 010129: JJMorcrette clean-up LERAD1H, NLNGR1H |
|---|
| 42 | ! M.Hamrud 01-Oct-2003 CY28 Cleaning |
|---|
| 43 | ! ------------------------------------------------------------------ |
|---|
| 44 | |
|---|
| 45 | USE PARKIND1 ,ONLY : JPIM ,JPRB |
|---|
| 46 | USE YOMHOOK ,ONLY : LHOOK, DR_HOOK |
|---|
| 47 | |
|---|
| 48 | USE PARRINT , ONLY : JPRADCW ,JPRADCE |
|---|
| 49 | USE YOMDIM , ONLY : NDGSAG ,NDGSAL ,NDGENG ,NDGENL ,NDLON |
|---|
| 50 | USE YOMCT0 , ONLY : NPRGPEW ,NPRINTLEV,LALLOPR |
|---|
| 51 | USE YOMLUN , ONLY : NULOUT |
|---|
| 52 | USE YOMGEM , ONLY : NLOENG |
|---|
| 53 | USE YOERAD , ONLY : & |
|---|
| 54 | & NRINT |
|---|
| 55 | USE YOMMP , ONLY : MY_REGION_NS ,MY_REGION_EW ,NSTA ,& |
|---|
| 56 | & NONL ,NPTRFRSTLAT,NPTRLSTLAT,NFRSTLAT ,NLSTLAT ,& |
|---|
| 57 | & LSPLITLAT |
|---|
| 58 | USE YOMPRAD , ONLY : LODBGRADI,LODBGRADL,NRIRINT ,NRFRSTOFF,& |
|---|
| 59 | & NRLASTOFF,NRIMAX ,NRIMAXT ,NRCNEEDW ,NRCNEEDE ,& |
|---|
| 60 | & NRCSNDW ,NRCSNDE ,NRCRCVW ,NRCRCVE ,NRCSNDT ,& |
|---|
| 61 | & NRCRCVT ,NRCRCVWO ,NRCRCVEO |
|---|
| 62 | |
|---|
| 63 | IMPLICIT NONE |
|---|
| 64 | |
|---|
| 65 | INTEGER(KIND=JPIM) :: ILWA (2*NPRGPEW) |
|---|
| 66 | INTEGER(KIND=JPIM) :: ILWB (2*NPRGPEW) |
|---|
| 67 | INTEGER(KIND=JPIM) :: ILWBI(2*NPRGPEW) |
|---|
| 68 | INTEGER(KIND=JPIM) :: ILEA (2*NPRGPEW) |
|---|
| 69 | INTEGER(KIND=JPIM) :: ILEB (2*NPRGPEW) |
|---|
| 70 | INTEGER(KIND=JPIM) :: ILEBI(2*NPRGPEW) |
|---|
| 71 | INTEGER(KIND=JPIM) :: ISTA(NDGENL,2*NPRGPEW) |
|---|
| 72 | INTEGER(KIND=JPIM) :: IONL(NDGENL,2*NPRGPEW) |
|---|
| 73 | CHARACTER (LEN = 14) :: CLDBG |
|---|
| 74 | |
|---|
| 75 | INTEGER(KIND=JPIM) :: IAO, IAOFF, IB, IB1, IB2, IB3, IB4, IB5,& |
|---|
| 76 | & IB6, ICNEED, ICTAKE, IGL, IJBXBOFF, & |
|---|
| 77 | & IJBXSETA, ILE, ILONS, ILW, IMAX, IMAXC, & |
|---|
| 78 | & IMAXT, IOTHBOFF, IOTHSETA, IPROCB, IRINT, & |
|---|
| 79 | & IU, IUNIT, JA, JB, JBE, JBW, JBX, JF, JGL, & |
|---|
| 80 | & JGLGLO, JL |
|---|
| 81 | |
|---|
| 82 | LOGICAL :: LLMYSETAISWEST, LLP |
|---|
| 83 | REAL(KIND=JPRB) :: ZHOOK_HANDLE |
|---|
| 84 | |
|---|
| 85 | #include "abor1.intfb.h" |
|---|
| 86 | |
|---|
| 87 | ! ---------------------------------------------------------------- |
|---|
| 88 | |
|---|
| 89 | IF (LHOOK) CALL DR_HOOK('SUECRADI',0,ZHOOK_HANDLE) |
|---|
| 90 | LLP = NPRINTLEV >= 1.OR. LALLOPR |
|---|
| 91 | IU = NULOUT |
|---|
| 92 | ALLOCATE(NRIRINT (NDGSAG:NDGENG)) |
|---|
| 93 | IF(LLP)WRITE(IU,9) 'NRIRINT ',SIZE(NRIRINT),SHAPE(NRIRINT) |
|---|
| 94 | ALLOCATE(NRIMAX (NDGSAG:NDGENG,2*NPRGPEW)) |
|---|
| 95 | IF(LLP)WRITE(IU,9) 'NRIMAX ',SIZE(NRIMAX),SHAPE(NRIMAX) |
|---|
| 96 | ALLOCATE(NRFRSTOFF(NDGSAG:NDGENG,2*NPRGPEW)) |
|---|
| 97 | IF(LLP)WRITE(IU,9) 'NRFRSTOFF ',SIZE(NRFRSTOFF),SHAPE(NRFRSTOFF) |
|---|
| 98 | ALLOCATE(NRLASTOFF(NDGSAG:NDGENG,2*NPRGPEW)) |
|---|
| 99 | IF(LLP)WRITE(IU,9) 'NRLASTOFF ',SIZE(NRLASTOFF),SHAPE(NRLASTOFF) |
|---|
| 100 | ALLOCATE(NRCNEEDW (NDGSAG:NDGENG,2*NPRGPEW)) |
|---|
| 101 | IF(LLP)WRITE(IU,9) 'NRCNEEDW ',SIZE(NRCNEEDW),SHAPE(NRCNEEDW) |
|---|
| 102 | ALLOCATE(NRCNEEDE (NDGSAG:NDGENG,2*NPRGPEW)) |
|---|
| 103 | IF(LLP)WRITE(IU,9) 'NRCNEEDE ',SIZE(NRCNEEDE),SHAPE(NRCNEEDE) |
|---|
| 104 | ALLOCATE(NRCSNDW (NDGSAG:NDGENG,NPRGPEW,-1:1)) |
|---|
| 105 | IF(LLP)WRITE(IU,9) 'NRCSNDW ',SIZE(NRCSNDW),SHAPE(NRCSNDW) |
|---|
| 106 | ALLOCATE(NRCSNDE (NDGSAG:NDGENG,NPRGPEW,-1:1)) |
|---|
| 107 | IF(LLP)WRITE(IU,9) 'NRCSNDE ',SIZE(NRCSNDE),SHAPE(NRCSNDE) |
|---|
| 108 | ALLOCATE(NRCRCVW (NDGSAG:NDGENG,NPRGPEW,-1:1)) |
|---|
| 109 | IF(LLP)WRITE(IU,9) 'NRCRCVW ',SIZE(NRCRCVW),SHAPE(NRCRCVW) |
|---|
| 110 | ALLOCATE(NRCRCVE (NDGSAG:NDGENG,NPRGPEW,-1:1)) |
|---|
| 111 | IF(LLP)WRITE(IU,9) 'NRCRCVE ',SIZE(NRCRCVE),SHAPE(NRCRCVE) |
|---|
| 112 | ALLOCATE(NRCSNDT (NPRGPEW,-1:1)) |
|---|
| 113 | IF(LLP)WRITE(IU,9) 'NRCSNDT ',SIZE(NRCSNDT),SHAPE(NRCSNDT) |
|---|
| 114 | ALLOCATE(NRCRCVT (NPRGPEW,-1:1)) |
|---|
| 115 | IF(LLP)WRITE(IU,9) 'NRCRCVT ',SIZE(NRCRCVT),SHAPE(NRCRCVT) |
|---|
| 116 | ALLOCATE(NRCRCVWO (NDGSAG:NDGENG,NPRGPEW,-1:1)) |
|---|
| 117 | IF(LLP)WRITE(IU,9) 'NRCRCVWO ',SIZE(NRCRCVWO),SHAPE(NRCRCVWO) |
|---|
| 118 | ALLOCATE(NRCRCVEO (NDGSAG:NDGENG,NPRGPEW,-1:1)) |
|---|
| 119 | IF(LLP)WRITE(IU,9) 'NRCRCVEO ',SIZE(NRCRCVEO),SHAPE(NRCRCVEO) |
|---|
| 120 | |
|---|
| 121 | 9 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8) |
|---|
| 122 | |
|---|
| 123 | ! INITIALISE GENERAL DATA STRUCTURES REQUIRED FOR RADIATION INTERPOLATION |
|---|
| 124 | |
|---|
| 125 | DO JGL=NDGSAG,NDGENG |
|---|
| 126 | NRIRINT(JGL)=0 |
|---|
| 127 | ENDDO |
|---|
| 128 | DO JB=1,2*NPRGPEW |
|---|
| 129 | DO JGL=NDGSAG,NDGENG |
|---|
| 130 | NRFRSTOFF(JGL,JB)=0 |
|---|
| 131 | NRLASTOFF(JGL,JB)=0 |
|---|
| 132 | NRIMAX (JGL,JB)=0 |
|---|
| 133 | NRCNEEDW (JGL,JB)=0 |
|---|
| 134 | NRCNEEDE (JGL,JB)=0 |
|---|
| 135 | ENDDO |
|---|
| 136 | ENDDO |
|---|
| 137 | NRIMAXT=0 |
|---|
| 138 | DO JA=-1,1 |
|---|
| 139 | DO JB=1,NPRGPEW |
|---|
| 140 | DO JGL=NDGSAG,NDGENG |
|---|
| 141 | NRCSNDW(JGL,JB,JA)=0 |
|---|
| 142 | NRCSNDE(JGL,JB,JA)=0 |
|---|
| 143 | NRCRCVW(JGL,JB,JA)=0 |
|---|
| 144 | NRCRCVE(JGL,JB,JA)=0 |
|---|
| 145 | NRCRCVWO(JGL,JB,JA)=0 |
|---|
| 146 | NRCRCVEO(JGL,JB,JA)=0 |
|---|
| 147 | ENDDO |
|---|
| 148 | ENDDO |
|---|
| 149 | ENDDO |
|---|
| 150 | DO JA=-1,1 |
|---|
| 151 | DO JB=1,NPRGPEW |
|---|
| 152 | NRCSNDT(JB,JA)=0 |
|---|
| 153 | NRCRCVT(JB,JA)=0 |
|---|
| 154 | ENDDO |
|---|
| 155 | ENDDO |
|---|
| 156 | |
|---|
| 157 | DO JB=1,2*NPRGPEW |
|---|
| 158 | DO JGL=1,NDGENL |
|---|
| 159 | ISTA(JGL,JB)=0 |
|---|
| 160 | IONL(JGL,JB)=0 |
|---|
| 161 | ENDDO |
|---|
| 162 | ENDDO |
|---|
| 163 | DO JB=1,NPRGPEW |
|---|
| 164 | DO JGL=1,NDGENL |
|---|
| 165 | IGL=NPTRFRSTLAT(MY_REGION_NS)-1+JGL |
|---|
| 166 | ISTA(JGL,JB)=NSTA(IGL,JB) |
|---|
| 167 | IONL(JGL,JB)=NONL(IGL,JB) |
|---|
| 168 | ENDDO |
|---|
| 169 | ENDDO |
|---|
| 170 | IF( LSPLITLAT(NFRSTLAT(MY_REGION_NS)) )THEN |
|---|
| 171 | LLMYSETAISWEST=.FALSE. |
|---|
| 172 | DO JB=1,NPRGPEW |
|---|
| 173 | IF( NSTA(NPTRFRSTLAT(MY_REGION_NS),JB) == 1 )THEN |
|---|
| 174 | LLMYSETAISWEST=.TRUE. |
|---|
| 175 | ENDIF |
|---|
| 176 | ENDDO |
|---|
| 177 | IF( LLMYSETAISWEST )THEN |
|---|
| 178 | DO JB=1,NPRGPEW |
|---|
| 179 | IGL=NPTRFRSTLAT(MY_REGION_NS+1) |
|---|
| 180 | ISTA(1,JB+NPRGPEW)=NSTA(IGL,JB) |
|---|
| 181 | IONL(1,JB+NPRGPEW)=NONL(IGL,JB) |
|---|
| 182 | ENDDO |
|---|
| 183 | ELSE |
|---|
| 184 | DO JB=1,NPRGPEW |
|---|
| 185 | IGL=NPTRFRSTLAT(MY_REGION_NS)-1 |
|---|
| 186 | ISTA(1,JB+NPRGPEW)=NSTA(IGL,JB) |
|---|
| 187 | IONL(1,JB+NPRGPEW)=NONL(IGL,JB) |
|---|
| 188 | ENDDO |
|---|
| 189 | ENDIF |
|---|
| 190 | ENDIF |
|---|
| 191 | IF( LSPLITLAT(NLSTLAT(MY_REGION_NS)) )THEN |
|---|
| 192 | LLMYSETAISWEST=.FALSE. |
|---|
| 193 | DO JB=1,NPRGPEW |
|---|
| 194 | IF( NSTA(NPTRLSTLAT(MY_REGION_NS),JB) == 1 )THEN |
|---|
| 195 | LLMYSETAISWEST=.TRUE. |
|---|
| 196 | ENDIF |
|---|
| 197 | ENDDO |
|---|
| 198 | IF( LLMYSETAISWEST )THEN |
|---|
| 199 | DO JB=1,NPRGPEW |
|---|
| 200 | IGL=NPTRFRSTLAT(MY_REGION_NS+1) |
|---|
| 201 | ISTA(NDGENL,JB+NPRGPEW)=NSTA(IGL,JB) |
|---|
| 202 | IONL(NDGENL,JB+NPRGPEW)=NONL(IGL,JB) |
|---|
| 203 | ENDDO |
|---|
| 204 | ELSE |
|---|
| 205 | DO JB=1,NPRGPEW |
|---|
| 206 | IGL=NPTRFRSTLAT(MY_REGION_NS)-1 |
|---|
| 207 | ISTA(NDGENL,JB+NPRGPEW)=NSTA(IGL,JB) |
|---|
| 208 | IONL(NDGENL,JB+NPRGPEW)=NONL(IGL,JB) |
|---|
| 209 | ENDDO |
|---|
| 210 | ENDIF |
|---|
| 211 | ENDIF |
|---|
| 212 | |
|---|
| 213 | IMAXC=NDLON/NRINT+6 |
|---|
| 214 | IMAXC=IMAXC+(1-MOD(IMAXC,2)) |
|---|
| 215 | |
|---|
| 216 | IF( LODBGRADI )THEN |
|---|
| 217 | IUNIT=10 |
|---|
| 218 | WRITE(CLDBG,'("debug_a",I3.3,"b",I3.3)')MY_REGION_NS,MY_REGION_EW |
|---|
| 219 | OPEN(UNIT=IUNIT,FILE=CLDBG) |
|---|
| 220 | WRITE(IUNIT,'("SUECRADI: MY_REGION_NS=",I4," MY_REGION_EW=",I4)')MY_REGION_NS,MY_REGION_EW |
|---|
| 221 | WRITE(IUNIT,'("SUECRADI: NDGSAL=",I4," NDGENL=",I4)') NDGSAL,NDGENL |
|---|
| 222 | WRITE(IUNIT,'("SUECRADI: ")') |
|---|
| 223 | ENDIF |
|---|
| 224 | |
|---|
| 225 | ! LOOP OVER OUR PARTITION LATITUDES, TO INITIALISE SIMPLE ITEMS |
|---|
| 226 | |
|---|
| 227 | IMAXT=0 |
|---|
| 228 | |
|---|
| 229 | DO JGL=1,NDGENL |
|---|
| 230 | |
|---|
| 231 | JGLGLO=NFRSTLAT(MY_REGION_NS)+JGL-1 |
|---|
| 232 | ILONS=NLOENG(JGLGLO) |
|---|
| 233 | |
|---|
| 234 | IRINT=1 |
|---|
| 235 | DO JF=1,NRINT |
|---|
| 236 | IF( MOD(ILONS,JF) == 0.AND.ILONS/JF <= IMAXC )THEN |
|---|
| 237 | IRINT=JF |
|---|
| 238 | EXIT |
|---|
| 239 | ENDIF |
|---|
| 240 | ENDDO |
|---|
| 241 | NRIRINT (JGL)=IRINT |
|---|
| 242 | |
|---|
| 243 | IF( LODBGRADI )THEN |
|---|
| 244 | WRITE(IUNIT,'("SUECRADI: JGLGLO=",I4," JGL=",I4,& |
|---|
| 245 | & " NLOENG=",I4," NRIRINT=",I1," LSPLITLAT=",L2)')& |
|---|
| 246 | & JGLGLO,JGL,NLOENG(JGLGLO),NRIRINT(JGL),LSPLITLAT(JGLGLO) |
|---|
| 247 | ENDIF |
|---|
| 248 | |
|---|
| 249 | IF( LSPLITLAT(JGLGLO) )THEN |
|---|
| 250 | IPROCB=2*NPRGPEW |
|---|
| 251 | ELSE |
|---|
| 252 | IPROCB=NPRGPEW |
|---|
| 253 | ENDIF |
|---|
| 254 | |
|---|
| 255 | DO JB=1,IPROCB |
|---|
| 256 | IF( IONL(JGL,JB) == 0 ) CYCLE |
|---|
| 257 | NRFRSTOFF(JGL,JB)=MOD(IRINT-MOD(ISTA(JGL,JB)-1,IRINT),IRINT) |
|---|
| 258 | NRLASTOFF(JGL,JB)=& |
|---|
| 259 | & MOD(IRINT-MOD(ISTA(JGL,JB)+IONL(JGL,JB)-2,IRINT),& |
|---|
| 260 | & IRINT) |
|---|
| 261 | IMAX=0 |
|---|
| 262 | DO JL=1+NRFRSTOFF(JGL,JB),IONL(JGL,JB),IRINT |
|---|
| 263 | IMAX=IMAX+1 |
|---|
| 264 | ENDDO |
|---|
| 265 | NRIMAX(JGL,JB)=IMAX |
|---|
| 266 | IF( NRFRSTOFF(JGL,JB) == 0 )THEN |
|---|
| 267 | NRCNEEDW (JGL,JB)=JPRADCW-1 |
|---|
| 268 | ELSE |
|---|
| 269 | NRCNEEDW (JGL,JB)=JPRADCW |
|---|
| 270 | ENDIF |
|---|
| 271 | IF( NRLASTOFF(JGL,JB) == 0 )THEN |
|---|
| 272 | NRCNEEDE (JGL,JB)=JPRADCE-1 |
|---|
| 273 | ELSE |
|---|
| 274 | NRCNEEDE (JGL,JB)=JPRADCE |
|---|
| 275 | ENDIF |
|---|
| 276 | IF( LODBGRADI )THEN |
|---|
| 277 | WRITE(IUNIT,'("SUECRADI: JB=",I4," ISTA=",I4,& |
|---|
| 278 | & " IONL=",I4," NRFRSTOFF=",I1," NRIMAX=",I3,& |
|---|
| 279 | & " NRLASTOFF=",I1," CNEEDW=",I1," CNEEDE=",I1)')& |
|---|
| 280 | & JB,ISTA(JGL,JB),IONL(JGL,JB),NRFRSTOFF(JGL,JB),& |
|---|
| 281 | & NRIMAX(JGL,JB),NRLASTOFF(JGL,JB),& |
|---|
| 282 | & NRCNEEDW(JGL,JB),NRCNEEDE(JGL,JB) |
|---|
| 283 | ENDIF |
|---|
| 284 | ENDDO |
|---|
| 285 | |
|---|
| 286 | IF( LODBGRADI )THEN |
|---|
| 287 | WRITE(IUNIT,'("SUECRADI: ")') |
|---|
| 288 | ENDIF |
|---|
| 289 | |
|---|
| 290 | IMAXT=IMAXT+NRIMAX(JGL,MY_REGION_EW) |
|---|
| 291 | |
|---|
| 292 | ENDDO |
|---|
| 293 | |
|---|
| 294 | NRIMAXT=IMAXT |
|---|
| 295 | IF( LODBGRADI )THEN |
|---|
| 296 | WRITE(IUNIT,'("SUECRADI: NRIMAXT=",I6)') NRIMAXT |
|---|
| 297 | ENDIF |
|---|
| 298 | |
|---|
| 299 | ! NOW LOOP OVER OUR PARTITION LATITUDES, TO DETERMINE SEND AND RECEIVE |
|---|
| 300 | ! INFORMATION |
|---|
| 301 | |
|---|
| 302 | DO JGL=1,NDGENL |
|---|
| 303 | |
|---|
| 304 | ! TEST IF WE HAVE ANY FINE POINTS |
|---|
| 305 | ! IF WE HAVEN'T, THEN WE DON'T HAVE TO SEND OR RECEIVE ANYTHING |
|---|
| 306 | |
|---|
| 307 | IF( IONL(JGL,MY_REGION_EW) == 0 ) CYCLE |
|---|
| 308 | JGLGLO=NFRSTLAT(MY_REGION_NS)+JGL-1 |
|---|
| 309 | |
|---|
| 310 | ! TEST IF CURRENT LATITUDE IS SPLIT ACROSS SET A's |
|---|
| 311 | ! TO SET IPROCB TO THE MAXIMUM NUMBER OF SETB's WE MUST CONSIDER IN |
|---|
| 312 | ! THE FOLLOWING CODE FOR THIS LATITUDE |
|---|
| 313 | |
|---|
| 314 | IF( LSPLITLAT(JGLGLO) )THEN |
|---|
| 315 | IPROCB=2*NPRGPEW |
|---|
| 316 | ELSE |
|---|
| 317 | IPROCB=NPRGPEW |
|---|
| 318 | ENDIF |
|---|
| 319 | |
|---|
| 320 | ! NOW CONSIDER EACH PARTITION (ON THIS LATITUDE) IN TURN TO SEE WHO |
|---|
| 321 | ! WILL BE SENDING TO AND RECEIVING FROM IT, AND OBVIOUSLY NOTING |
|---|
| 322 | ! PERTINENT INFO IF OUR PARTITION IS SENDING OR RECEIVING |
|---|
| 323 | |
|---|
| 324 | DO JBX=1,IPROCB |
|---|
| 325 | |
|---|
| 326 | ! LET'S START BY BUILDING UP A LIST OF WESTERLY AND EASTERLY PARTITIONS |
|---|
| 327 | ! CONTAINING ONE OR MORE FINE POINTS, SO THAT WE CAN SUBSEQUENTLY IGNORE |
|---|
| 328 | ! ISSUES ABOUT WHETHER THIS IS A SPLIT LATITUDE AND THAT THE EARTH IS |
|---|
| 329 | ! ROUND. ALSO THE PARTITION BEING CONSIDERED (JBX) ALWAYS APPEARS AT THE |
|---|
| 330 | ! END OF EACH OF THESE LISTS, BECAUSE JBX MAY NEED TO 'LOGICALLY' SEND/RECEIVE |
|---|
| 331 | ! COURSE POINTS TO/FROM ITS OWN PARTITION FOR THIS LATITUDE. |
|---|
| 332 | |
|---|
| 333 | ILW=0 |
|---|
| 334 | ILE=0 |
|---|
| 335 | IF( LSPLITLAT(JGLGLO) )THEN |
|---|
| 336 | |
|---|
| 337 | ! DETERMINE WHETHER THE SET A SHARING THIS LATITUDE IS (ABOVE,LEFT) OR |
|---|
| 338 | ! (BELOW,RIGHT). WE DETERMINE THIS BY TESTING IF ANY SETB ON THIS LATITUDE |
|---|
| 339 | ! STARTS AT 1. |
|---|
| 340 | |
|---|
| 341 | IAOFF=-1 |
|---|
| 342 | DO JB=1,NPRGPEW |
|---|
| 343 | IF( ISTA(JGL,JB) == 1 )THEN |
|---|
| 344 | IAOFF=1 |
|---|
| 345 | EXIT |
|---|
| 346 | ENDIF |
|---|
| 347 | ENDDO |
|---|
| 348 | |
|---|
| 349 | IF( JBX <= NPRGPEW )THEN |
|---|
| 350 | IJBXSETA=MY_REGION_NS |
|---|
| 351 | IOTHSETA=MY_REGION_NS+IAOFF |
|---|
| 352 | IJBXBOFF=0 |
|---|
| 353 | IOTHBOFF=NPRGPEW |
|---|
| 354 | ELSE |
|---|
| 355 | IJBXSETA=MY_REGION_NS+IAOFF |
|---|
| 356 | IOTHSETA=MY_REGION_NS |
|---|
| 357 | IJBXBOFF=NPRGPEW |
|---|
| 358 | IOTHBOFF=0 |
|---|
| 359 | ENDIF |
|---|
| 360 | ! INITIALISE WEST LIST, SPLIT LAT |
|---|
| 361 | IF( JBX <= NPRGPEW )THEN |
|---|
| 362 | IB1=JBX-1 |
|---|
| 363 | IB2=1 |
|---|
| 364 | IB3=2*NPRGPEW |
|---|
| 365 | IB4=NPRGPEW+1 |
|---|
| 366 | IB5=NPRGPEW |
|---|
| 367 | IB6=JBX |
|---|
| 368 | ELSE |
|---|
| 369 | IB1=JBX-1 |
|---|
| 370 | IB2=NPRGPEW+1 |
|---|
| 371 | IB3=NPRGPEW |
|---|
| 372 | IB4=1 |
|---|
| 373 | IB5=2*NPRGPEW |
|---|
| 374 | IB6=JBX |
|---|
| 375 | ENDIF |
|---|
| 376 | DO JB=IB1,IB2,-1 |
|---|
| 377 | IF( IONL(JGL,JB) > 0 )THEN |
|---|
| 378 | ILW=ILW+1 |
|---|
| 379 | ILWA (ILW)=IJBXSETA |
|---|
| 380 | ILWB (ILW)=JB-IJBXBOFF |
|---|
| 381 | ILWBI(ILW)=JB |
|---|
| 382 | ENDIF |
|---|
| 383 | ENDDO |
|---|
| 384 | DO JB=IB3,IB4,-1 |
|---|
| 385 | IF( IONL(JGL,JB) > 0 )THEN |
|---|
| 386 | ILW=ILW+1 |
|---|
| 387 | ILWA (ILW)=IOTHSETA |
|---|
| 388 | ILWB (ILW)=JB-IOTHBOFF |
|---|
| 389 | ILWBI(ILW)=JB |
|---|
| 390 | ENDIF |
|---|
| 391 | ENDDO |
|---|
| 392 | DO JB=IB5,IB6,-1 |
|---|
| 393 | IF( IONL(JGL,JB) > 0 )THEN |
|---|
| 394 | ILW=ILW+1 |
|---|
| 395 | ILWA (ILW)=IJBXSETA |
|---|
| 396 | ILWB (ILW)=JB-IJBXBOFF |
|---|
| 397 | ILWBI(ILW)=JB |
|---|
| 398 | ENDIF |
|---|
| 399 | ENDDO |
|---|
| 400 | ! INITIALISE EAST LIST, SPLIT LAT |
|---|
| 401 | IF( JBX <= NPRGPEW )THEN |
|---|
| 402 | IB1=JBX+1 |
|---|
| 403 | IB2=NPRGPEW |
|---|
| 404 | IB3=NPRGPEW+1 |
|---|
| 405 | IB4=2*NPRGPEW |
|---|
| 406 | IB5=1 |
|---|
| 407 | IB6=JBX |
|---|
| 408 | ELSE |
|---|
| 409 | IB1=JBX+1 |
|---|
| 410 | IB2=2*NPRGPEW |
|---|
| 411 | IB3=1 |
|---|
| 412 | IB4=NPRGPEW |
|---|
| 413 | IB5=NPRGPEW+1 |
|---|
| 414 | IB6=JBX |
|---|
| 415 | ENDIF |
|---|
| 416 | DO JB=IB1,IB2 |
|---|
| 417 | IF( IONL(JGL,JB) > 0 )THEN |
|---|
| 418 | ILE=ILE+1 |
|---|
| 419 | ILEA (ILE)=IJBXSETA |
|---|
| 420 | ILEB (ILE)=JB-IJBXBOFF |
|---|
| 421 | ILEBI(ILE)=JB |
|---|
| 422 | ENDIF |
|---|
| 423 | ENDDO |
|---|
| 424 | DO JB=IB3,IB4 |
|---|
| 425 | IF( IONL(JGL,JB) > 0 )THEN |
|---|
| 426 | ILE=ILE+1 |
|---|
| 427 | ILEA (ILE)=IOTHSETA |
|---|
| 428 | ILEB (ILE)=JB-IOTHBOFF |
|---|
| 429 | ILEBI(ILE)=JB |
|---|
| 430 | ENDIF |
|---|
| 431 | ENDDO |
|---|
| 432 | DO JB=IB5,IB6 |
|---|
| 433 | IF( IONL(JGL,JB) > 0 )THEN |
|---|
| 434 | ILE=ILE+1 |
|---|
| 435 | ILEA (ILE)=IJBXSETA |
|---|
| 436 | ILEB (ILE)=JB-IJBXBOFF |
|---|
| 437 | ILEBI(ILE)=JB |
|---|
| 438 | ENDIF |
|---|
| 439 | ENDDO |
|---|
| 440 | ELSE |
|---|
| 441 | IAOFF=0 |
|---|
| 442 | ! INITIALISE WEST LIST, NOT SPLIT LAT |
|---|
| 443 | DO JB=JBX-1,1,-1 |
|---|
| 444 | IF( IONL(JGL,JB) > 0 )THEN |
|---|
| 445 | ILW=ILW+1 |
|---|
| 446 | ILWA (ILW)=MY_REGION_NS |
|---|
| 447 | ILWB (ILW)=JB |
|---|
| 448 | ILWBI(ILW)=JB |
|---|
| 449 | ENDIF |
|---|
| 450 | ENDDO |
|---|
| 451 | DO JB=NPRGPEW,JBX,-1 |
|---|
| 452 | IF( IONL(JGL,JB) > 0 )THEN |
|---|
| 453 | ILW=ILW+1 |
|---|
| 454 | ILWA (ILW)=MY_REGION_NS |
|---|
| 455 | ILWB (ILW)=JB |
|---|
| 456 | ILWBI(ILW)=JB |
|---|
| 457 | ENDIF |
|---|
| 458 | ENDDO |
|---|
| 459 | ! INITIALISE EAST LIST, NOT SPLIT LAT |
|---|
| 460 | DO JB=JBX+1,NPRGPEW |
|---|
| 461 | IF( IONL(JGL,JB) > 0 )THEN |
|---|
| 462 | ILE=ILE+1 |
|---|
| 463 | ILEA (ILE)=MY_REGION_NS |
|---|
| 464 | ILEB (ILE)=JB |
|---|
| 465 | ILEBI(ILE)=JB |
|---|
| 466 | ENDIF |
|---|
| 467 | ENDDO |
|---|
| 468 | DO JB=1,JBX |
|---|
| 469 | IF( IONL(JGL,JB) > 0 )THEN |
|---|
| 470 | ILE=ILE+1 |
|---|
| 471 | ILEA (ILE)=MY_REGION_NS |
|---|
| 472 | ILEB (ILE)=JB |
|---|
| 473 | ILEBI(ILE)=JB |
|---|
| 474 | ENDIF |
|---|
| 475 | ENDDO |
|---|
| 476 | ENDIF |
|---|
| 477 | IF( ILW > 2*NPRGPEW .OR. ILE > 2*NPRGPEW )THEN |
|---|
| 478 | WRITE(NULOUT,'("SUECRAD: ILW > 2*NPRGPEW .OR. ",& |
|---|
| 479 | & "ILE > 2*NPRGPEW, ILW=",I6," ILE=",I6)') ILW,ILE |
|---|
| 480 | CALL ABOR1('SUECRADI:ILW/E > 2*NPRGPEW') |
|---|
| 481 | ENDIF |
|---|
| 482 | |
|---|
| 483 | ! DETERMINE FOR PARTITION JBX THOSE PARTITIONS THAT IT HAS TO RECEIVE |
|---|
| 484 | ! COURSE POINTS FROM. |
|---|
| 485 | ! DO THIS BY SEARCHING DOWN THE WESTERN LIST OF PARTITIONS FIRST AND THEN |
|---|
| 486 | ! FOR THE EASTERN LIST OF PARTITIONS. |
|---|
| 487 | ! THE SEND AND RECEIVE INFO FOR THIS (MY_REGION_NS,MY_REGION_EW) IS DETERMINED BY |
|---|
| 488 | ! SIMPLY NOTING WHETHER (MY_REGION_NS,MY_REGION_EW) IS A SENDER OR RECEIVER IN THE |
|---|
| 489 | ! ABOVE LIST SEARCH PROCESS. |
|---|
| 490 | |
|---|
| 491 | ICNEED=NRCNEEDW(JGL,JBX) |
|---|
| 492 | |
|---|
| 493 | DO JBW=1,ILW |
|---|
| 494 | IF( ICNEED == 0 ) EXIT |
|---|
| 495 | |
|---|
| 496 | ! DOES THIS PARTITION HAVE ANY COURSE POINTS |
|---|
| 497 | |
|---|
| 498 | IF( NRIMAX(JGL,ILWBI(JBW)) > 0 )THEN |
|---|
| 499 | |
|---|
| 500 | ! YES, IT DOES |
|---|
| 501 | ! THEN TEST IF IT HAS ENOUGH TO SATISFY OUR NEED |
|---|
| 502 | |
|---|
| 503 | IF( NRIMAX(JGL,ILWBI(JBW)) >= ICNEED )THEN |
|---|
| 504 | ICTAKE=ICNEED |
|---|
| 505 | ELSE |
|---|
| 506 | ICTAKE=NRIMAX(JGL,ILWBI(JBW)) |
|---|
| 507 | ENDIF |
|---|
| 508 | IF( MY_REGION_NS == ILWA(JBW).AND.MY_REGION_EW == ILWB(JBW) )THEN |
|---|
| 509 | ! WE (MY_REGION_NS,MY_REGION_EW) ARE THE SENDER (SENDING EAST COURSE POINTS) |
|---|
| 510 | IF( JBX <= NPRGPEW )THEN |
|---|
| 511 | IB =JBX |
|---|
| 512 | IAO=0 |
|---|
| 513 | ELSE |
|---|
| 514 | IB =JBX-NPRGPEW |
|---|
| 515 | IAO=IAOFF |
|---|
| 516 | ENDIF |
|---|
| 517 | NRCSNDE(JGL,IB,IAO)=ICTAKE |
|---|
| 518 | NRCSNDT(IB,IAO)=NRCSNDT(IB,IAO)+ICTAKE |
|---|
| 519 | ENDIF |
|---|
| 520 | IF( JBX == MY_REGION_EW )THEN |
|---|
| 521 | ! WE (MY_REGION_NS,MY_REGION_EW) ARE THE RECEIVER |
|---|
| 522 | IB =ILWB(JBW) |
|---|
| 523 | IAO=ILWA(JBW)-MY_REGION_NS |
|---|
| 524 | NRCRCVW (JGL,IB,IAO)=ICTAKE |
|---|
| 525 | NRCRCVWO(JGL,IB,IAO)=ICNEED-ICTAKE |
|---|
| 526 | NRCRCVT (IB,IAO)=NRCRCVT(IB,IAO)+ICTAKE |
|---|
| 527 | ENDIF |
|---|
| 528 | ICNEED=ICNEED-ICTAKE |
|---|
| 529 | ENDIF |
|---|
| 530 | ENDDO |
|---|
| 531 | |
|---|
| 532 | ICNEED=NRCNEEDE(JGL,JBX) |
|---|
| 533 | |
|---|
| 534 | DO JBE=1,ILE |
|---|
| 535 | IF( ICNEED == 0 ) EXIT |
|---|
| 536 | |
|---|
| 537 | ! DOES THIS PARTITION HAVE ANY COURSE POINTS |
|---|
| 538 | |
|---|
| 539 | IF( NRIMAX(JGL,ILEBI(JBE)) > 0 )THEN |
|---|
| 540 | |
|---|
| 541 | ! YES, IT DOES |
|---|
| 542 | ! THEN TEST IF IT HAS ENOUGH TO SATISFY OUR NEED |
|---|
| 543 | |
|---|
| 544 | IF( NRIMAX(JGL,ILEBI(JBE)) >= ICNEED )THEN |
|---|
| 545 | ICTAKE=ICNEED |
|---|
| 546 | ELSE |
|---|
| 547 | ICTAKE=NRIMAX(JGL,ILEBI(JBE)) |
|---|
| 548 | ENDIF |
|---|
| 549 | IF( MY_REGION_NS == ILEA(JBE).AND.MY_REGION_EW == ILEB(JBE) )THEN |
|---|
| 550 | ! WE (MY_REGION_NS,MY_REGION_EW) ARE THE SENDER (SENDING WEST COURSE POINTS) |
|---|
| 551 | IF( JBX <= NPRGPEW )THEN |
|---|
| 552 | IB =JBX |
|---|
| 553 | IAO=0 |
|---|
| 554 | ELSE |
|---|
| 555 | IB =JBX-NPRGPEW |
|---|
| 556 | IAO=IAOFF |
|---|
| 557 | ENDIF |
|---|
| 558 | NRCSNDW(JGL,IB,IAO)=ICTAKE |
|---|
| 559 | NRCSNDT(IB,IAO)=NRCSNDT(IB,IAO)+ICTAKE |
|---|
| 560 | ENDIF |
|---|
| 561 | IF( JBX == MY_REGION_EW )THEN |
|---|
| 562 | ! WE (MY_REGION_NS,MY_REGION_EW) ARE THE RECEIVER |
|---|
| 563 | IB =ILEB(JBE) |
|---|
| 564 | IAO=ILEA(JBE)-MY_REGION_NS |
|---|
| 565 | NRCRCVE (JGL,IB,IAO)=ICTAKE |
|---|
| 566 | NRCRCVEO(JGL,IB,IAO)=NRCNEEDW(JGL,JBX)+NRCNEEDE(JGL,JBX)-ICNEED |
|---|
| 567 | NRCRCVT (IB,IAO)=NRCRCVT(IB,IAO)+ICTAKE |
|---|
| 568 | ENDIF |
|---|
| 569 | ICNEED=ICNEED-ICTAKE |
|---|
| 570 | ENDIF |
|---|
| 571 | ENDDO |
|---|
| 572 | |
|---|
| 573 | ENDDO |
|---|
| 574 | |
|---|
| 575 | ! END OF JBX LOOP OVER PARTITIONS |
|---|
| 576 | |
|---|
| 577 | ENDDO |
|---|
| 578 | |
|---|
| 579 | ! END OF JGL LOOP OVER LATITUDES |
|---|
| 580 | |
|---|
| 581 | ! WRITE OUT SEND/RECEIVE TABLES IF DEBUGGING |
|---|
| 582 | |
|---|
| 583 | IF( LODBGRADI )THEN |
|---|
| 584 | DO JA=-1,1 |
|---|
| 585 | WRITE(IUNIT,'("SUECRADI: ")') |
|---|
| 586 | DO JB=1,NPRGPEW |
|---|
| 587 | IF( NRCSNDT(JB,JA) > 0.OR. NRCRCVT(JB,JA) > 0 )THEN |
|---|
| 588 | WRITE(IUNIT,'("SUECRADI: SETA=",I4," SETB=",I4,& |
|---|
| 589 | & " NRCSNDT=",I6," NRCRCVT=",I6)')& |
|---|
| 590 | & JA+MY_REGION_NS,JB,NRCSNDT(JB,JA),NRCRCVT(JB,JA) |
|---|
| 591 | ENDIF |
|---|
| 592 | ENDDO |
|---|
| 593 | ENDDO |
|---|
| 594 | |
|---|
| 595 | WRITE(IUNIT,'("SUECRADI: ")') |
|---|
| 596 | |
|---|
| 597 | DO JA=-1,1 |
|---|
| 598 | WRITE(IUNIT,'("SUECRADI: ")') |
|---|
| 599 | DO JB=1,NPRGPEW |
|---|
| 600 | DO JGL=1,NDGENL |
|---|
| 601 | JGLGLO=NFRSTLAT(MY_REGION_NS)+JGL-1 |
|---|
| 602 | IF( NRCSNDW(JGL,JB,JA) > 0.OR.& |
|---|
| 603 | & NRCSNDE(JGL,JB,JA) > 0.OR.& |
|---|
| 604 | & NRCRCVW(JGL,JB,JA) > 0.OR.& |
|---|
| 605 | & NRCRCVE(JGL,JB,JA) > 0 )THEN |
|---|
| 606 | WRITE(IUNIT,'("SUECRADI: JGLGLO=",I4," JGL=",I4,& |
|---|
| 607 | & " SETA=",I4," SETB=",I4,& |
|---|
| 608 | & " CSNDW=",I6," CSNDE=",I6,& |
|---|
| 609 | & " CRCVW=",I6," CRCVE=",I6,& |
|---|
| 610 | & " CRCVWO=",I1," CRCVEO=",I1)')& |
|---|
| 611 | & JGLGLO,JGL,JA+MY_REGION_NS,JB,& |
|---|
| 612 | & NRCSNDW(JGL,JB,JA),NRCSNDE(JGL,JB,JA),& |
|---|
| 613 | & NRCRCVW(JGL,JB,JA),NRCRCVE(JGL,JB,JA),& |
|---|
| 614 | & NRCRCVWO(JGL,JB,JA),NRCRCVEO(JGL,JB,JA) |
|---|
| 615 | ENDIF |
|---|
| 616 | ENDDO |
|---|
| 617 | ENDDO |
|---|
| 618 | ENDDO |
|---|
| 619 | IF( .NOT.LODBGRADL )THEN |
|---|
| 620 | CLOSE(UNIT=IUNIT) |
|---|
| 621 | ENDIF |
|---|
| 622 | ENDIF |
|---|
| 623 | |
|---|
| 624 | ! ------------------------------------------------------------------ |
|---|
| 625 | |
|---|
| 626 | IF (LHOOK) CALL DR_HOOK('SUECRADI',1,ZHOOK_HANDLE) |
|---|
| 627 | END SUBROUTINE SUECRADI |
|---|
