| 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 | |
|---|
