| 1 | SUBROUTINE preproc (kindex, kfield) |
|---|
| 2 | USE mod_kinds_oasis |
|---|
| 3 | C**** |
|---|
| 4 | C ***************************** |
|---|
| 5 | C * OASIS ROUTINE - LEVEL 1 * |
|---|
| 6 | C * ------------- ------- * |
|---|
| 7 | C ***************************** |
|---|
| 8 | C |
|---|
| 9 | C**** *preproc* - preprocess routine |
|---|
| 10 | C |
|---|
| 11 | C |
|---|
| 12 | C Purpose: |
|---|
| 13 | C ------- |
|---|
| 14 | C Do the field preprocessing |
|---|
| 15 | C |
|---|
| 16 | C** Interface: |
|---|
| 17 | C --------- |
|---|
| 18 | C *CALL* *preproc (kindex, kfield)* |
|---|
| 19 | C |
|---|
| 20 | C Input: |
|---|
| 21 | C ----- |
|---|
| 22 | C kindex : field identificator array (integer 1D) |
|---|
| 23 | C kfield : number of fields for current iteration (integer) |
|---|
| 24 | C |
|---|
| 25 | C Output: |
|---|
| 26 | C ------ |
|---|
| 27 | C None |
|---|
| 28 | C |
|---|
| 29 | C Workspace: |
|---|
| 30 | C --------- |
|---|
| 31 | C zcocoef : additional field coefficients for correct (real 1D) |
|---|
| 32 | C inip : array for reduced grid data for redglo (integer 1D) |
|---|
| 33 | C clcofld : additional field names for correct (character 1D) |
|---|
| 34 | C clcofic : array to handle data file names (character 1D) |
|---|
| 35 | C iunit : array to handle I/O units of data files (integer 1D) |
|---|
| 36 | C |
|---|
| 37 | C Externals: |
|---|
| 38 | C --------- |
|---|
| 39 | C correct, extrap, extraw, invert, masq, redglo, chkfld |
|---|
| 40 | C |
|---|
| 41 | C Reference: |
|---|
| 42 | C --------- |
|---|
| 43 | C See OASIS manual (1998) |
|---|
| 44 | C |
|---|
| 45 | C History: |
|---|
| 46 | C ------- |
|---|
| 47 | C Version Programmer Date Description |
|---|
| 48 | C ------- ---------- ---- ----------- |
|---|
| 49 | C 2.0 L. Terray 95/09/01 created |
|---|
| 50 | C 2.1 L. Terray 96/09/25 modified: Call to chkfld |
|---|
| 51 | C 2.2 L. Terray 97/12/16 Added: new extrapolation |
|---|
| 52 | C and change call to extrap |
|---|
| 53 | C 2.3 L. Terray 99/03/01 modified: call to extrap |
|---|
| 54 | C 2.3 S. Valcke 99/03/16 modified for T213 and T319 |
|---|
| 55 | C 2.3 S. Valcke 99/03/16 modified for T213 and T319 |
|---|
| 56 | C 2.3 S. Valcke 99/03/26 changed troncature for number of |
|---|
| 57 | C latitude between equator and pole |
|---|
| 58 | C 2.3 S. Valcke 99/03/30 changed arguments in CALL to extrap |
|---|
| 59 | C 2.3 S. Valcke 99/04/30 added: printing levels |
|---|
| 60 | C 2.3 L. Terray 99/09/15 changed periodicity variables |
|---|
| 61 | C 2.5 S. Valcke 00/09/05 Changed iintflx for itinpflx |
|---|
| 62 | C |
|---|
| 63 | C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% |
|---|
| 64 | C |
|---|
| 65 | C* -----------------Include files and USE of modules--------------------------- |
|---|
| 66 | C |
|---|
| 67 | USE mod_parameter |
|---|
| 68 | USE mod_string |
|---|
| 69 | USE mod_analysis |
|---|
| 70 | USE mod_memory |
|---|
| 71 | USE mod_extrapol |
|---|
| 72 | USE mod_unit |
|---|
| 73 | USE mod_gauss |
|---|
| 74 | USE mod_label |
|---|
| 75 | USE mod_printing |
|---|
| 76 | C |
|---|
| 77 | C* ---------------------------- Argument declarations ------------------- |
|---|
| 78 | C |
|---|
| 79 | INTEGER (kind=ip_intwp_p) kindex(kfield) |
|---|
| 80 | C |
|---|
| 81 | C* ---------------------------- Local declarations ---------------------- |
|---|
| 82 | C |
|---|
| 83 | INTEGER (kind=ip_intwp_p) inip(320) |
|---|
| 84 | INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: iunit |
|---|
| 85 | REAL (kind=ip_realwp_p),DIMENSION(:), ALLOCATABLE :: zcocoef |
|---|
| 86 | CHARACTER*8 clxordbf, clyordbf, clextmet, clname, clmsk, clper |
|---|
| 87 | CHARACTER*8 clfic, clstrg |
|---|
| 88 | CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: clcofic, clcofld |
|---|
| 89 | CHARACTER*32 clabel |
|---|
| 90 | C |
|---|
| 91 | C* ---------------------------- Poema verses ---------------------------- |
|---|
| 92 | C |
|---|
| 93 | C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% |
|---|
| 94 | C |
|---|
| 95 | C* 1. Initialization and allocation of local arrays |
|---|
| 96 | C --------------------------------------------- |
|---|
| 97 | C |
|---|
| 98 | IF (nlogprt .GE. 1) THEN |
|---|
| 99 | WRITE (UNIT = nulou,FMT = *) ' ' |
|---|
| 100 | WRITE (UNIT = nulou,FMT = *) ' ' |
|---|
| 101 | WRITE (UNIT = nulou,FMT = *) |
|---|
| 102 | $ ' ROUTINE preproc - Level 1' |
|---|
| 103 | WRITE (UNIT = nulou,FMT = *) |
|---|
| 104 | $ ' *************** *******' |
|---|
| 105 | WRITE (UNIT = nulou,FMT = *) ' ' |
|---|
| 106 | WRITE (UNIT = nulou,FMT = *) |
|---|
| 107 | $ ' Preprocessing of coupling fields' |
|---|
| 108 | WRITE (UNIT = nulou,FMT = *) ' ' |
|---|
| 109 | WRITE (UNIT = nulou,FMT = *) ' ' |
|---|
| 110 | ENDIF |
|---|
| 111 | C |
|---|
| 112 | ALLOCATE (iunit(ig_maxcomb),stat=il_err) |
|---|
| 113 | IF (il_err.NE.0) CALL prtout ('Error in "iunit" allocation of |
|---|
| 114 | $ cookart ',il_err,1) |
|---|
| 115 | ALLOCATE (zcocoef(ig_maxcomb),stat=il_err) |
|---|
| 116 | IF (il_err.NE.0) CALL prtout ('Error in "zcocoef" allocation of |
|---|
| 117 | $ cookart ',il_err,1) |
|---|
| 118 | ALLOCATE (clcofic(ig_maxcomb),stat=il_err) |
|---|
| 119 | IF (il_err.NE.0) CALL prtout ('Error in "clcofic" allocation of |
|---|
| 120 | $ cookart ',il_err,1) |
|---|
| 121 | ALLOCATE (clcofld(ig_maxcomb),stat=il_err) |
|---|
| 122 | IF (il_err.NE.0) CALL prtout ('Error in "clcofld" allocation of |
|---|
| 123 | $ cookart ',il_err,1) |
|---|
| 124 | iunit(:)=0 |
|---|
| 125 | zcocoef(:)=0 |
|---|
| 126 | clcofic(:)=' ' |
|---|
| 127 | clcofld(:)=' ' |
|---|
| 128 | C |
|---|
| 129 | C* Zeroes work array |
|---|
| 130 | C |
|---|
| 131 | CALL szero (work,ig_work) |
|---|
| 132 | CALL izero (nwork,ig_nwork) |
|---|
| 133 | C |
|---|
| 134 | C |
|---|
| 135 | C* 2. Do the job |
|---|
| 136 | C ---------- |
|---|
| 137 | !$omp parallel do default (shared) |
|---|
| 138 | !$omp+ private (ja,jf,ji,jc) |
|---|
| 139 | !$omp+ private (ifield,clname,ilataf) |
|---|
| 140 | !$omp+ private (clabel,clextmet,ineibor) |
|---|
| 141 | !$omp+ private (ipdeb,ilatbf,ilonbf) |
|---|
| 142 | !$omp+ private (iadrold,iadrold_grid,isizold) |
|---|
| 143 | !$omp+ private (clfic,ilun,clper) |
|---|
| 144 | !$omp+ private (clstrg,ilabel) |
|---|
| 145 | !$omp+ private (iloc,clintmet,clgrdtyp,clfldtyp) |
|---|
| 146 | !$omp+ private (icofld) |
|---|
| 147 | !$omp+ private (clfilfic,itinpflx,zfldcoef) |
|---|
| 148 | !$omp+ private (iper,itronca,clmsk,iredu) |
|---|
| 149 | !$omp+ private (zmskval,clxordbf,clyordbf) |
|---|
| 150 | |
|---|
| 151 | C |
|---|
| 152 | DO 210 jf = 1, kfield |
|---|
| 153 | C |
|---|
| 154 | C* Assign local variables |
|---|
| 155 | C |
|---|
| 156 | ifield = kindex(jf) |
|---|
| 157 | ilabel = numlab(ifield) |
|---|
| 158 | clname = cnaminp(ifield) |
|---|
| 159 | clabel = cfldlab(ilabel) |
|---|
| 160 | iadrold = nadrold(ifield) |
|---|
| 161 | iadrold_grid = nadrold_grid(ifield) |
|---|
| 162 | isizold = nsizold(ifield) |
|---|
| 163 | ilonbf = nlonbf(ifield) |
|---|
| 164 | ilatbf = nlatbf(ifield) |
|---|
| 165 | itinpflx = ntinpflx(ifield) |
|---|
| 166 | C |
|---|
| 167 | C* Print field name |
|---|
| 168 | C |
|---|
| 169 | IF (nlogprt .GE. 1) THEN |
|---|
| 170 | CALL prcout('Treatment of field :', clname, 2) |
|---|
| 171 | ENDIF |
|---|
| 172 | C |
|---|
| 173 | C* - Do preprocessing analysis |
|---|
| 174 | C |
|---|
| 175 | DO 220 ja = 1, ig_ntrans(ifield) |
|---|
| 176 | IF (canal(ja,ifield) .EQ. 'MASK') THEN |
|---|
| 177 | C |
|---|
| 178 | C* --->>> Mask |
|---|
| 179 | C |
|---|
| 180 | zmskval = amskval(ifield) |
|---|
| 181 | !$omp critical |
|---|
| 182 | CALL masq (fldold(iadrold), isizold, zmskval, |
|---|
| 183 | $ mskold(iadrold_grid)) |
|---|
| 184 | !$omp end critical |
|---|
| 185 | C |
|---|
| 186 | C* --->>> Invert |
|---|
| 187 | C |
|---|
| 188 | ELSE IF (canal(ja,ifield) .EQ. 'INVERT') THEN |
|---|
| 189 | clxordbf = cxordbf(ifield) |
|---|
| 190 | clyordbf = cyordbf(ifield) |
|---|
| 191 | CALL invert (fldold(iadrold), ilonbf, |
|---|
| 192 | $ ilatbf, clxordbf, clyordbf) |
|---|
| 193 | C |
|---|
| 194 | C* --->>> Checkin: perform basic checks on input field |
|---|
| 195 | C |
|---|
| 196 | ELSE IF (canal(ja,ifield) .EQ. 'CHECKIN') THEN |
|---|
| 197 | CALL chkfld(clname, clabel, |
|---|
| 198 | $ fldold(iadrold), mskold(iadrold_grid), |
|---|
| 199 | $ surold(iadrold_grid), |
|---|
| 200 | $ isizold, ilonbf, itinpflx) |
|---|
| 201 | C |
|---|
| 202 | C* --->>> Flux correction |
|---|
| 203 | C |
|---|
| 204 | ELSE IF (canal(ja,ifield) .EQ. 'CORRECT') THEN |
|---|
| 205 | C |
|---|
| 206 | C* Assign local variables to main field coefficient |
|---|
| 207 | C |
|---|
| 208 | zfldcoef = afldcoef(ifield) |
|---|
| 209 | C |
|---|
| 210 | C* Get loop index to read additional fields, coefficients, filenames |
|---|
| 211 | C and related logical units |
|---|
| 212 | C |
|---|
| 213 | icofld = ncofld(ifield) |
|---|
| 214 | DO 230 jc = 1, icofld |
|---|
| 215 | clcofld(jc) = ccofld(jc,ifield) |
|---|
| 216 | zcocoef(jc) = acocoef(jc,ifield) |
|---|
| 217 | clcofic(jc) = ccofic(jc,ifield) |
|---|
| 218 | iunit(jc) = nludat(jc,ifield) |
|---|
| 219 | 230 CONTINUE |
|---|
| 220 | C |
|---|
| 221 | C* Zero work array |
|---|
| 222 | C |
|---|
| 223 | CALL szero (work, ig_work) |
|---|
| 224 | C |
|---|
| 225 | C* Do the job |
|---|
| 226 | C |
|---|
| 227 | CALL correct (fldold(iadrold), isizold, |
|---|
| 228 | $ zfldcoef, icofld, zcocoef(1), |
|---|
| 229 | $ work(1), iunit(1), clcofic(1), |
|---|
| 230 | $ clcofld(1)) |
|---|
| 231 | C |
|---|
| 232 | C* --->>> Extrap |
|---|
| 233 | C |
|---|
| 234 | ELSE IF (canal(ja,ifield) .EQ. 'EXTRAP') THEN |
|---|
| 235 | clextmet = cextmet(ifield) |
|---|
| 236 | ineibor = neighbor(ifield) |
|---|
| 237 | C |
|---|
| 238 | C* 8-nearest neighbors extrapolation |
|---|
| 239 | C |
|---|
| 240 | IF (clextmet .EQ. 'NINENN') THEN |
|---|
| 241 | zmskval = amskval(ifield) |
|---|
| 242 | clper = csper(ifield) |
|---|
| 243 | iper = nosper(ifield) |
|---|
| 244 | C |
|---|
| 245 | C* Zero work array |
|---|
| 246 | C |
|---|
| 247 | CALL szero (work, ig_work) |
|---|
| 248 | C |
|---|
| 249 | C* Do it now |
|---|
| 250 | C |
|---|
| 251 | #ifdef key_openmp |
|---|
| 252 | niwtn=0 |
|---|
| 253 | #endif |
|---|
| 254 | !$omp critical |
|---|
| 255 | CALL extrap (fldold(iadrold), zmskval, work(1), |
|---|
| 256 | $ mskold(iadrold_grid), ilonbf, ilatbf, |
|---|
| 257 | $ ineibor, clextmet, clper, iper, |
|---|
| 258 | $ niwtn(ifield), nninnfl(ifield)) |
|---|
| 259 | C |
|---|
| 260 | !$omp end critical |
|---|
| 261 | C* N-weighted neighbors extrapolation |
|---|
| 262 | C |
|---|
| 263 | ELSE IF (clextmet .EQ. 'WEIGHT') THEN |
|---|
| 264 | clfic = cgrdext(ifield) |
|---|
| 265 | ilun = nluext(ifield) |
|---|
| 266 | iloc = nextfl(ifield) |
|---|
| 267 | clstrg = cficbf(ifield)//cficbf(ifield) |
|---|
| 268 | ipdeb = (nextfl(ifield)-1)*ig_maxext*ig_maxgrd+1 |
|---|
| 269 | C |
|---|
| 270 | C* Do it now |
|---|
| 271 | C |
|---|
| 272 | CALL extraw (fldold(iadrold), mskold(iadrold_grid), |
|---|
| 273 | $ isizold, clfic, ilun, clstrg, iloc, |
|---|
| 274 | $ aextra(ipdeb), nextra(ipdeb), ineibor, |
|---|
| 275 | $ lextra(ifield)) |
|---|
| 276 | ENDIF |
|---|
| 277 | lextrapdone(ifield) = .true. |
|---|
| 278 | C |
|---|
| 279 | C* --->>> Redglo |
|---|
| 280 | C |
|---|
| 281 | ELSE IF (canal(ja,ifield) .EQ. 'REDGLO') THEN |
|---|
| 282 | itronca = ntronca(ifield) |
|---|
| 283 | clmsk = cmskrd(ifield) |
|---|
| 284 | zmskval = amskred |
|---|
| 285 | C |
|---|
| 286 | C* get number of longitudes by latitude circle and total number of points |
|---|
| 287 | C reduced grid |
|---|
| 288 | C |
|---|
| 289 | C* Zero work array |
|---|
| 290 | C |
|---|
| 291 | CALL szero (work, ig_work) |
|---|
| 292 | CALL izero (nwork, ig_nwork) |
|---|
| 293 | CALL izero (inip, 320) |
|---|
| 294 | IF (itronca .EQ. 16) THEN |
|---|
| 295 | DO 240 ji = 1, itronca |
|---|
| 296 | inip(ji) = ninip16(ji) |
|---|
| 297 | 240 CONTINUE |
|---|
| 298 | iredu = nredu16 |
|---|
| 299 | ELSE IF (itronca .EQ. 24) THEN |
|---|
| 300 | DO 250 ji = 1, itronca |
|---|
| 301 | inip(ji) = ninip24(ji) |
|---|
| 302 | 250 CONTINUE |
|---|
| 303 | iredu = nredu24 |
|---|
| 304 | ELSE IF (itronca .EQ. 32) THEN |
|---|
| 305 | DO 260 ji = 1, itronca |
|---|
| 306 | inip(ji) = ninip32(ji) |
|---|
| 307 | 260 CONTINUE |
|---|
| 308 | iredu = nredu32 |
|---|
| 309 | ELSE IF (itronca .EQ. 48) THEN |
|---|
| 310 | DO 270 ji = 1, itronca |
|---|
| 311 | inip(ji) = ninip48(ji) |
|---|
| 312 | 270 CONTINUE |
|---|
| 313 | iredu = nredu48 |
|---|
| 314 | ELSE IF (itronca .EQ. 80) THEN |
|---|
| 315 | DO 280 ji = 1, itronca |
|---|
| 316 | inip(ji) = ninip80(ji) |
|---|
| 317 | 280 CONTINUE |
|---|
| 318 | iredu = nredu80 |
|---|
| 319 | ELSE IF (itronca .EQ. 160) THEN |
|---|
| 320 | DO 285 ji = 1, itronca |
|---|
| 321 | inip(ji) = ninip160(ji) |
|---|
| 322 | 285 CONTINUE |
|---|
| 323 | iredu = nredu160 |
|---|
| 324 | ELSE |
|---|
| 325 | CALL prtout |
|---|
| 326 | $ ('WARNING!!! Oasis cannot treat this grid with 2*NO |
|---|
| 327 | $ latitude lines with NO = ', itronca, 2) |
|---|
| 328 | CALL prtout |
|---|
| 329 | $ ('Implement data for NO =', itronca, 2) |
|---|
| 330 | CALL HALTE('STOP in preproc') |
|---|
| 331 | ENDIF |
|---|
| 332 | DO 290 ji = ilatbf/2 + 1, ilatbf |
|---|
| 333 | inip(ji) = inip(ilatbf - ji + 1) |
|---|
| 334 | 290 CONTINUE |
|---|
| 335 | CALL redglo (fldold(iadrold), work(1), iredu, inip, |
|---|
| 336 | $ ilonbf, ilatbf, nwork(1), nwork(1+iredu), |
|---|
| 337 | $ itronca, zmskval, clmsk) |
|---|
| 338 | ELSE |
|---|
| 339 | CONTINUE |
|---|
| 340 | END IF |
|---|
| 341 | 220 CONTINUE |
|---|
| 342 | 210 CONTINUE |
|---|
| 343 | C |
|---|
| 344 | C |
|---|
| 345 | C* 3. Deallocation and end of routine |
|---|
| 346 | C ------------------------------- |
|---|
| 347 | C |
|---|
| 348 | DEALLOCATE(iunit) |
|---|
| 349 | DEALLOCATE(zcocoef) |
|---|
| 350 | DEALLOCATE(clcofic) |
|---|
| 351 | DEALLOCATE(clcofld) |
|---|
| 352 | C |
|---|
| 353 | IF (nlogprt .GE. 1) THEN |
|---|
| 354 | WRITE (UNIT = nulou,FMT = *) ' ' |
|---|
| 355 | WRITE (UNIT = nulou,FMT = *) |
|---|
| 356 | $ ' --------- End of routine preproc ---------' |
|---|
| 357 | CALL FLUSH (nulou) |
|---|
| 358 | ENDIF |
|---|
| 359 | RETURN |
|---|
| 360 | END |
|---|
