wrfv2_fire/share/sint.F

   1
   2       SUBROUTINE SINT(XF,                        &
   3                    ims, ime, jms, jme, icmask ,  &
   4                    its, ite, jts, jte, nf, xstag, ystag )
   5       IMPLICIT NONE
   6       INTEGER ims, ime, jms, jme, &
   7               its, ite, jts, jte
   8
   9       LOGICAL icmask( ims:ime, jms:jme )
  10       LOGICAL xstag, ystag
  11
  12       INTEGER nf, ior
  13       REAL    one12, one24, ep
  14       PARAMETER(one12=1./12.,one24=1./24.)
  15       PARAMETER(ior=2)
  16 !
  17       REAL XF(ims:ime,jms:jme,NF)
  18 !
  19       REAL Y(ims:ime,jms:jme,-IOR:IOR),    &
  20            Z(ims:ime,jms:jme,-IOR:IOR),    &
  21            F(ims:ime,jms:jme,0:1)
  22 !
  23       INTEGER I,J,II,JJ,IIM
  24       INTEGER N2STAR, N2END, N1STAR, N1END
  25 !
  26       DATA  EP/ 1.E-10/
  27
  28       REAL W(ims:ime,jms:jme),OV(ims:ime,jms:jme),UN(ims:ime,jms:jme)
  29       REAL MXM(ims:ime,jms:jme),MN(ims:ime,jms:jme)
  30       REAL FL(ims:ime,jms:jme,0:1)
  31       REAL XIG(NF*NF), XJG(NF*NF)  ! NF is parent to child grid refinement ratio
  32       INTEGER IFRST
  33       integer rr
  34       COMMON /DEPAR2/ IFRST
  35       DATA IFRST /1/
  36
  37       REAL rioff, rjoff
  38 !
  39       REAL donor, y1, y2, a
  40       DONOR(Y1,Y2,A)=(Y1*AMAX1(0.,SIGN(1.,A))-Y2*AMIN1(0.,SIGN(1.,A)))*A
  41       REAL tr4, ym1, y0, yp1, yp2
  42       TR4(YM1,Y0,YP1,YP2,A)=A*ONE12*(7.*(YP1+Y0)-(YP2+YM1))               &
  43        -A*A*ONE24*(15.*(YP1-Y0)-(YP2-YM1))-A*A*A*ONE12*((YP1+Y0)          &
  44        -(YP2+YM1))+A*A*A*A*ONE24*(3.*(YP1-Y0)-(YP2-YM1))
  45       REAL pp, pn, x
  46       PP(X)=AMAX1(0.,X)
  47       PN(X)=AMIN1(0.,X)
  48
  49       rr = nint(sqrt(float(nf)))
  50 !!      write(6,*) ' nf, rr are ',nf,rr
  51
  52       rioff = 0
  53       rjoff = 0
  54       if(xstag .and. (mod(rr,2) .eq. 0)) rioff = 1.
  55       if(ystag .and. (mod(rr,2) .eq. 0)) rjoff = 1.
  56
  57       DO I=1,rr
  58         DO J=1,rr
  59           XIG(J+(I-1)*rr)=(float(rr)-1.-rioff)/float(2*rr)-FLOAT(J-1)*1./float(rr)
  60           XJG(J+(I-1)*rr)=(float(rr)-1.-rjoff)/float(2*rr)-FLOAT(I-1)*1./float(rr)
  61         ENDDO
  62       ENDDO
  63       IFRST = 0
  64
  65       N2STAR = jts
  66       N2END  = jte
  67       N1STAR = its
  68       N1END  = ite
  69
  70       DO 2000 IIM=1,NF
  71 !
  72 !  HERE STARTS RESIDUAL ADVECTION
  73 !
  74         DO 9000 JJ=N2STAR,N2END
  75           DO 50 J=-IOR,IOR
  76
  77             DO 51 I=-IOR,IOR
  78               DO 511 II=N1STAR,N1END
  79                 IF ( icmask(II,JJ) ) Y(II,JJ,I)=XF(II+I,JJ+J,IIM)
  80   511         CONTINUE
  81    51       CONTINUE
  82
  83             DO 811 II=N1STAR,N1END
  84               IF ( icmask(II,JJ) ) THEN
  85                 FL(II,JJ,0)=DONOR(Y(II,JJ,-1),Y(II,JJ,0),XIG(IIM))
  86                 FL(II,JJ,1)=DONOR(Y(II,JJ,0),Y(II,JJ,1),XIG(IIM))
  87               ENDIF
  88   811         CONTINUE
  89             DO 812 II=N1STAR,N1END
  90               IF ( icmask(II,JJ) ) W(II,JJ)=Y(II,JJ,0)-(FL(II,JJ,1)-FL(II,JJ,0))
  91   812         CONTINUE
  92             DO 813 II=N1STAR,N1END
  93               IF ( icmask(II,JJ) ) THEN
  94                 MXM(II,JJ)=                                             &
  95                          AMAX1(Y(II,JJ,-1),Y(II,JJ,0),Y(II,JJ,1),       &
  96                          W(II,JJ))
  97                 MN(II,JJ)=AMIN1(Y(II,JJ,-1),Y(II,JJ,0),Y(II,JJ,1),W(II,JJ))
  98               ENDIF
  99   813         CONTINUE
 100             DO 312 II=N1STAR,N1END
 101               IF ( icmask(II,JJ) ) THEN
 102                 F(II,JJ,0)=                                               &
 103                            TR4(Y(II,JJ,-2),Y(II,JJ,-1),Y(II,JJ,0),        &
 104                            Y(II,JJ,1),XIG(IIM))
 105                 F(II,JJ,1)=                                                 &
 106                          TR4(Y(II,JJ,-1),Y(II,JJ,0),Y(II,JJ,1),Y(II,JJ,2),&
 107                          XIG(IIM))
 108                 ENDIF
 109   312         CONTINUE
 110             DO 822 II=N1STAR,N1END
 111               IF ( icmask(II,JJ) ) THEN
 112                 F(II,JJ,0)=F(II,JJ,0)-FL(II,JJ,0)
 113                 F(II,JJ,1)=F(II,JJ,1)-FL(II,JJ,1)
 114               ENDIF
 115   822         CONTINUE
 116             DO 823 II=N1STAR,N1END
 117               IF ( icmask(II,JJ) ) THEN
 118                 OV(II,JJ)=(MXM(II,JJ)-W(II,JJ))/(-PN(F(II,JJ,1))+         &
 119                         PP(F(II,JJ,0))+EP)
 120                 UN(II,JJ)=(W(II,JJ)-MN(II,JJ))/(PP(F(II,JJ,1))-             &
 121                       PN(F(II,JJ,0))+EP)
 122               ENDIF
 123   823         CONTINUE
 124             DO 824 II=N1STAR,N1END
 125               IF ( icmask(II,JJ) ) THEN
 126                 F(II,JJ,0)=PP(F(II,JJ,0))*AMIN1(1.,OV(II,JJ))+            &
 127                            PN(F(II,JJ,0))*AMIN1(1.,UN(II,JJ))
 128                 F(II,JJ,1)=PP(F(II,JJ,1))*AMIN1(1.,UN(II,JJ))+            &
 129                            PN(F(II,JJ,1))*AMIN1(1.,OV(II,JJ))
 130               ENDIF
 131   824         CONTINUE
 132             DO 825 II=N1STAR,N1END
 133               IF ( icmask(II,JJ) ) THEN
 134                 Y(II,JJ,0)=W(II,JJ)-(F(II,JJ,1)-F(II,JJ,0))
 135               ENDIF
 136   825         CONTINUE
 137             DO 361 II=N1STAR,N1END
 138               IF ( icmask(II,JJ) ) Z(II,JJ,J)=Y(II,JJ,0)
 139   361         CONTINUE
 140 !
 141 !  END IF FIRST J LOOP
 142 !
 143  8000       CONTINUE
 144    50     CONTINUE
 145
 146           DO 911 II=N1STAR,N1END
 147             IF ( icmask(II,JJ) ) THEN
 148               FL(II,JJ,0)=DONOR(Z(II,JJ,-1),Z(II,JJ,0),XJG(IIM))
 149               FL(II,JJ,1)=DONOR(Z(II,JJ,0),Z(II,JJ,1),XJG(IIM))
 150             ENDIF
 151   911       CONTINUE
 152           DO 912 II=N1STAR,N1END
 153             IF ( icmask(II,JJ) ) W(II,JJ)=Z(II,JJ,0)-(FL(II,JJ,1)-FL(II,JJ,0))
 154   912       CONTINUE
 155           DO 913 II=N1STAR,N1END
 156             IF ( icmask(II,JJ) ) THEN
 157               MXM(II,JJ)=AMAX1(Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1),W(II,JJ))
 158               MN(II,JJ)=AMIN1(Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1),W(II,JJ))
 159             ENDIF
 160   913       CONTINUE
 161           DO 412 II=N1STAR,N1END
 162             IF ( icmask(II,JJ) ) THEN
 163               F(II,JJ,0)=                                                 &
 164                          TR4(Z(II,JJ,-2),Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1)&
 165                          ,XJG(IIM))
 166               F(II,JJ,1)=                                                   &
 167                          TR4(Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1),Z(II,JJ,2),  &
 168                          XJG(IIM))
 169             ENDIF
 170   412       CONTINUE
 171           DO 922 II=N1STAR,N1END
 172             IF ( icmask(II,JJ) ) THEN
 173               F(II,JJ,0)=F(II,JJ,0)-FL(II,JJ,0)
 174               F(II,JJ,1)=F(II,JJ,1)-FL(II,JJ,1)
 175             ENDIF
 176   922       CONTINUE
 177           DO 923 II=N1STAR,N1END
 178             IF ( icmask(II,JJ) ) THEN
 179               OV(II,JJ)=(MXM(II,JJ)-W(II,JJ))/(-PN(F(II,JJ,1))+           &
 180                         PP(F(II,JJ,0))+EP)
 181               UN(II,JJ)=(W(II,JJ)-MN(II,JJ))/(PP(F(II,JJ,1))-PN(F(II,JJ,0))+ &
 182                       EP)
 183             ENDIF
 184   923       CONTINUE
 185           DO 924 II=N1STAR,N1END
 186             IF ( icmask(II,JJ) ) THEN
 187               F(II,JJ,0)=PP(F(II,JJ,0))*AMIN1(1.,OV(II,JJ))+PN(F(II,JJ,0))  &
 188                          *AMIN1(1.,UN(II,JJ))
 189               F(II,JJ,1)=PP(F(II,JJ,1))*AMIN1(1.,UN(II,JJ))+PN(F(II,JJ,1))  &
 190                          *AMIN1(1.,OV(II,JJ))
 191             ENDIF
 192   924     CONTINUE
 193  9000   CONTINUE
 194         DO 925 JJ=N2STAR,N2END
 195           DO 925 II=N1STAR,N1END
 196             IF ( icmask(II,JJ) ) XF(II,JJ,IIM)=W(II,JJ)-(F(II,JJ,1)-F(II,JJ,0))
 197   925     CONTINUE
 198
 199 !
 200  2000 CONTINUE
 201       RETURN
 202       END
 203
 204 ! Version of sint that replaces mask with detailed ranges for avoiding boundaries
 205 ! may help performance by getting the conditionals out of innner loops
 206
 207       SUBROUTINE SINTB(XF1, XF ,                  &
 208                    ims, ime, jms, jme, icmask ,  &
 209                    its, ite, jts, jte, nf, xstag, ystag )
 210       IMPLICIT NONE
 211       INTEGER ims, ime, jms, jme, &
 212               its, ite, jts, jte
 213
 214       LOGICAL icmask( ims:ime, jms:jme )
 215       LOGICAL xstag, ystag
 216
 217       INTEGER nf, ior
 218       REAL    one12, one24, ep
 219       PARAMETER(one12=1./12.,one24=1./24.)
 220       PARAMETER(ior=2)
 221 !
 222       REAL XF(ims:ime,jms:jme,NF)
 223       REAL XF1(ims:ime,jms:jme,NF)
 224 !
 225       REAL Y(ims:ime,jms:jme,-IOR:IOR),    &
 226            Z(ims:ime,jms:jme,-IOR:IOR),    &
 227            F(ims:ime,jms:jme,0:1)
 228 !
 229       INTEGER I,J,II,JJ,IIM
 230       INTEGER N2STAR, N2END, N1STAR, N1END
 231 !
 232       DATA  EP/ 1.E-10/
 233 !
 234 !      PARAMETER(NONOS=1)
 235 !      PARAMETER(N1OS=N1*NONOS+1-NONOS,N2OS=N2*NONOS+1-NONOS)
 236 !
 237       REAL W(ims:ime,jms:jme),OV(ims:ime,jms:jme),UN(ims:ime,jms:jme)
 238       REAL MXM(ims:ime,jms:jme),MN(ims:ime,jms:jme)
 239       REAL FL(ims:ime,jms:jme,0:1)
 240       REAL XIG(NF*NF), XJG(NF*NF)  ! NF is the parent to child grid refinement ratio
 241       INTEGER IFRST
 242       integer rr
 243       COMMON /DEPAR2B/ IFRST
 244       DATA IFRST /1/
 245
 246       REAL rioff, rjoff
 247 !
 248       REAL donor, y1, y2, a
 249       DONOR(Y1,Y2,A)=(Y1*AMAX1(0.,SIGN(1.,A))-Y2*AMIN1(0.,SIGN(1.,A)))*A
 250       REAL tr4, ym1, y0, yp1, yp2
 251       TR4(YM1,Y0,YP1,YP2,A)=A*ONE12*(7.*(YP1+Y0)-(YP2+YM1))               &
 252        -A*A*ONE24*(15.*(YP1-Y0)-(YP2-YM1))-A*A*A*ONE12*((YP1+Y0)          &
 253        -(YP2+YM1))+A*A*A*A*ONE24*(3.*(YP1-Y0)-(YP2-YM1))
 254       REAL pp, pn, x
 255       PP(X)=AMAX1(0.,X)
 256       PN(X)=AMIN1(0.,X)
 257
 258       rr = nint(sqrt(float(nf)))
 259
 260       rioff = 0
 261       rjoff = 0
 262       if(xstag .and. (mod(rr,2) .eq. 0)) rioff = 1.
 263       if(ystag .and. (mod(rr,2) .eq. 0)) rjoff = 1.
 264
 265       DO I=1,rr
 266         DO J=1,rr
 267           XIG(J+(I-1)*rr)=(float(rr)-1.-rioff)/float(2*rr)-FLOAT(J-1)*1./float(rr)
 268           XJG(J+(I-1)*rr)=(float(rr)-1.-rjoff)/float(2*rr)-FLOAT(I-1)*1./float(rr)
 269         ENDDO
 270       ENDDO
 271       IFRST = 0
 272
 273       N2STAR = jts
 274       N2END  = jte
 275       N1STAR = its
 276       N1END  = ite
 277
 278       DO 2000 IIM=1,NF
 279 !
 280 !  HERE STARTS RESIDUAL ADVECTION
 281 !
 282         DO 9000 JJ=N2STAR,N2END
 283 !cdir unroll=5
 284           DO 50 J=-IOR,IOR
 285
 286 !cdir unroll=5
 287             DO 51 I=-IOR,IOR
 288               DO 511 II=N1STAR,N1END
 289                 Y(II,JJ,I)=XF1(II+I,JJ+J,IIM)
 290   511         CONTINUE
 291    51       CONTINUE
 292
 293             DO 811 II=N1STAR,N1END
 294               FL(II,JJ,0)=DONOR(Y(II,JJ,-1),Y(II,JJ,0),XIG(IIM))
 295               FL(II,JJ,1)=DONOR(Y(II,JJ,0),Y(II,JJ,1),XIG(IIM))
 296   811         CONTINUE
 297             DO 812 II=N1STAR,N1END
 298               W(II,JJ)=Y(II,JJ,0)-(FL(II,JJ,1)-FL(II,JJ,0))
 299   812         CONTINUE
 300             DO 813 II=N1STAR,N1END
 301               MXM(II,JJ)=                                             &
 302                        AMAX1(Y(II,JJ,-1),Y(II,JJ,0),Y(II,JJ,1),       &
 303                        W(II,JJ))
 304               MN(II,JJ)=AMIN1(Y(II,JJ,-1),Y(II,JJ,0),Y(II,JJ,1),W(II,JJ))
 305   813         CONTINUE
 306             DO 312 II=N1STAR,N1END
 307               F(II,JJ,0)=                                               &
 308                          TR4(Y(II,JJ,-2),Y(II,JJ,-1),Y(II,JJ,0),        &
 309                          Y(II,JJ,1),XIG(IIM))
 310               F(II,JJ,1)=                                                 &
 311                        TR4(Y(II,JJ,-1),Y(II,JJ,0),Y(II,JJ,1),Y(II,JJ,2),&
 312                        XIG(IIM))
 313   312         CONTINUE
 314             DO 822 II=N1STAR,N1END
 315               F(II,JJ,0)=F(II,JJ,0)-FL(II,JJ,0)
 316               F(II,JJ,1)=F(II,JJ,1)-FL(II,JJ,1)
 317   822         CONTINUE
 318             DO 823 II=N1STAR,N1END
 319               OV(II,JJ)=(MXM(II,JJ)-W(II,JJ))/(-PN(F(II,JJ,1))+         &
 320                       PP(F(II,JJ,0))+EP)
 321               UN(II,JJ)=(W(II,JJ)-MN(II,JJ))/(PP(F(II,JJ,1))-             &
 322                     PN(F(II,JJ,0))+EP)
 323   823         CONTINUE
 324             DO 824 II=N1STAR,N1END
 325               F(II,JJ,0)=PP(F(II,JJ,0))*AMIN1(1.,OV(II,JJ))+            &
 326                          PN(F(II,JJ,0))*AMIN1(1.,UN(II,JJ))
 327               F(II,JJ,1)=PP(F(II,JJ,1))*AMIN1(1.,UN(II,JJ))+            &
 328                          PN(F(II,JJ,1))*AMIN1(1.,OV(II,JJ))
 329   824         CONTINUE
 330             DO 825 II=N1STAR,N1END
 331               Y(II,JJ,0)=W(II,JJ)-(F(II,JJ,1)-F(II,JJ,0))
 332   825         CONTINUE
 333             DO 361 II=N1STAR,N1END
 334               Z(II,JJ,J)=Y(II,JJ,0)
 335   361         CONTINUE
 336 !
 337 !  END IF FIRST J LOOP
 338 !
 339  8000       CONTINUE
 340    50     CONTINUE
 341
 342           DO 911 II=N1STAR,N1END
 343             FL(II,JJ,0)=DONOR(Z(II,JJ,-1),Z(II,JJ,0),XJG(IIM))
 344             FL(II,JJ,1)=DONOR(Z(II,JJ,0),Z(II,JJ,1),XJG(IIM))
 345   911       CONTINUE
 346           DO 912 II=N1STAR,N1END
 347             W(II,JJ)=Z(II,JJ,0)-(FL(II,JJ,1)-FL(II,JJ,0))
 348   912       CONTINUE
 349           DO 913 II=N1STAR,N1END
 350             MXM(II,JJ)=AMAX1(Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1),W(II,JJ))
 351             MN(II,JJ)=AMIN1(Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1),W(II,JJ))
 352   913       CONTINUE
 353           DO 412 II=N1STAR,N1END
 354             F(II,JJ,0)=                                                 &
 355                        TR4(Z(II,JJ,-2),Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1)&
 356                        ,XJG(IIM))
 357             F(II,JJ,1)=                                                   &
 358                        TR4(Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1),Z(II,JJ,2),  &
 359                        XJG(IIM))
 360   412       CONTINUE
 361           DO 922 II=N1STAR,N1END
 362             F(II,JJ,0)=F(II,JJ,0)-FL(II,JJ,0)
 363             F(II,JJ,1)=F(II,JJ,1)-FL(II,JJ,1)
 364   922       CONTINUE
 365           DO 923 II=N1STAR,N1END
 366             OV(II,JJ)=(MXM(II,JJ)-W(II,JJ))/(-PN(F(II,JJ,1))+           &
 367                       PP(F(II,JJ,0))+EP)
 368             UN(II,JJ)=(W(II,JJ)-MN(II,JJ))/(PP(F(II,JJ,1))-PN(F(II,JJ,0))+ &
 369                     EP)
 370   923       CONTINUE
 371           DO 924 II=N1STAR,N1END
 372             F(II,JJ,0)=PP(F(II,JJ,0))*AMIN1(1.,OV(II,JJ))+PN(F(II,JJ,0))  &
 373                        *AMIN1(1.,UN(II,JJ))
 374             F(II,JJ,1)=PP(F(II,JJ,1))*AMIN1(1.,UN(II,JJ))+PN(F(II,JJ,1))  &
 375                        *AMIN1(1.,OV(II,JJ))
 376   924     CONTINUE
 377  9000   CONTINUE
 378         DO 925 JJ=N2STAR,N2END
 379           DO 925 II=N1STAR,N1END
 380             XF(II,JJ,IIM)=W(II,JJ)-(F(II,JJ,1)-F(II,JJ,0))
 381   925     CONTINUE
 382
 383 !
 384  2000 CONTINUE
 385       RETURN
 386       END
 387
 388