SUBROUTINE W3FT05(ALOLA,APOLA,W1,W2,LINEAR) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: W3FT05 CONVERT (145,37) TO (65,65) N. HEMI. GRID C AUTHOR: JONES,R.E. ORG: W342 DATE: 85-04-08 C C ABSTRACT: CONVERT A NORTHERN HEMISPHERE 2.5 DEGREE LAT.,LON. 145 BY C 37 GRID TO A POLAR STEREOGRAPHIC 65 BY 65 GRID. THE POLAR C STEREOGRAPHIC MAP PROJECTION IS TRUE AT 60 DEG. N. , THE MESH C LENGTH IS 381 KM. AND THE ORIENTION IS 80 DEG. W. C C PROGRAM HISTORY LOG: C 85-04-08 R.E.JONES C 91-07-30 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN C 92-05-02 R.E.JONES ADD SAVE C C USAGE: CALL W3FT05(ALOLA,APOLA,W1,W2,LINEAR) C C INPUT VARIABLES: C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES C ------ --------- ----------------------------------------------- C ALOLA ARG LIST 145*37 GRID 2.5 LAT,LON GRID N. HEMI. C 5365 POINT GRID IS TYPE 29 OR 1D HEX O.N. 84 C LINEAR ARG LIST 1 LINEAR INTERPOLATION , NE.1 BIQUADRATIC C C OUTPUT VARIABLES: C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES C ------ --------- ----------------------------------------------- C APOLA ARG LIST 65*65 GRID OF NORTHERN HEMI. C 4225 POINT GRID IS TYPE 27 OR 1B HEX O.N. 84 C W1 ARG LIST 65*65 SCRATCH FIELD C W2 ARG LIST 65*65 SCRATCH FIELD C C SUBPROGRAMS CALLED: C NAMES LIBRARY C ------------------------------------------------------- -------- C ASIN ATAN2 SYSTEM C C REMARKS: C C 1. W1 AND W2 ARE USED TO STORE SETS OF CONSTANTS WHICH ARE C REUSABLE FOR REPEATED CALLS TO THE SUBROUTINE. IF THEY ARE C OVER WRITTEN BY THE USER, A WARNING MESSAGE WILL BE PRINTED C AND W1 AND W2 WILL BE RECOMPUTED. C C 2. WIND COMPONENTS ARE NOT ROTATED TO THE 65*65 GRID ORIENTATION C AFTER INTERPOLATION. YOU MAY USE W3FC08 TO DO THIS. C C 3. THE GRID POINTS VALUES ON THE EQUATOR HAVE BEEN EXTRAPOLATED C OUTWARD TO ALL THE GRID POINTS OUTSIDE THE EQUATOR ON THE 65*65 C GRID (ABOUT 1100 POINTS). C C 4. YOU SHOULD USE THE CRAY VECTORIZED VERSION W3FT05V ON THE CRAY C IT HAS 3 PARAMETERS IN THE CALL, RUNS ABOUT 10 TIMES FASTER. USES C MORE MEMORY. C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN C MACHINE: CRAY Y-MP8/832 C C$$$ C REAL ALOLA(145,37) REAL APOLA(4225) REAL ERAS(4) REAL SAVEW1(10) REAL SAVEW2(10) REAL W1(4225) REAL W2(4225) C INTEGER JY(4) INTEGER OUT C LOGICAL LIN C SAVE C DATA DEGPRD/57.2957795/ DATA EARTHR/6371.2/ DATA ISWT /0/ DATA OUT /6/ C 4000 FORMAT ( 52H *** WARNING , W1 OR W2 SCRATCH FILES OVER WRITTEN ,, & 43H I WILL RESTORE THEM , BURNING UP CPU TIME,, & 14H IN W3FT05 ***) C LIN = .FALSE. IF (LINEAR.EQ.1) LIN = .TRUE. C IF (ISWT.EQ.0) GO TO 300 C C TEST W1 AND W2 TO SEE IF THEY WERE WRITTEN OVER C DO 100 KK=1,10 IF (SAVEW1(KK).NE.W1(KK)) GO TO 200 IF (SAVEW2(KK).NE.W2(KK)) GO TO 200 100 CONTINUE GOTO 1000 C 200 CONTINUE WRITE (OUT,4000) C 300 CONTINUE DEG = 2.5 NN = 0 XMESH = 381.0 GI2 = (1.86603*EARTHR) / XMESH GI2 = GI2 * GI2 C C DO LOOP 800 PUTS SUBROUTINE W3FB01 IN LINE C DO 800 J = 1,65 XJ = J - 33 XJ2 = XJ * XJ DO 800 I=1,65 XI = I - 33 R2 = XI*XI + XJ2 IF (R2.NE.0.0) GO TO 400 WLON = 0.0 XLAT = 90.0 GO TO 700 400 CONTINUE XLONG = DEGPRD * ATAN2(XJ,XI) IF (XLONG.GE.0.0) GO TO 500 WLON = -10.0 - XLONG IF (WLON.LT.0.0) WLON = WLON + 360.0 GO TO 600 C 500 CONTINUE WLON = 350.0 - XLONG 600 CONTINUE XLAT = ASIN((GI2-R2)/(GI2+R2))*DEGPRD 700 CONTINUE IF (WLON.GT.360.0) WLON = WLON - 360.0 IF (WLON.LT.0.0) WLON = WLON + 360.0 NN = NN + 1 W1(NN) = ( 360.0 - WLON ) / DEG + 1.0 W2(NN) = XLAT / DEG + 1.0 800 CONTINUE C DO 900 KK = 1,10 SAVEW1(KK) = W1(KK) SAVEW2(KK) = W2(KK) 900 CONTINUE C ISWT = 1 C 1000 CONTINUE C DO 2100 KK = 1,4225 I = W1(KK) J = W2(KK) FI = I FJ = J XDELI = W1(KK) - FI XDELJ = W2(KK) - FJ IP1 = I + 1 JY(3) = J + 1 JY(2) = J IF (LIN) GO TO 1100 IP2 = I + 2 IM1 = I - 1 JY(4) = J + 2 JY(1) = J - 1 XI2TM = XDELI * (XDELI-1.) * 0.25 XJ2TM = XDELJ * (XDELJ-1.) * 0.25 C 1100 CONTINUE IF ((I.LT.2).OR.(J.LT.2)) GO TO 1200 IF ((I.GT.142).OR.(J.GT.34)) GO TO 1200 C C QUADRATIC (LINEAR TOO) OK W/O FURTHER ADO SO GO TO 1700 C GO TO 1700 C 1200 CONTINUE IF (I.EQ.1) GO TO 1300 IF (I.EQ.144) GO TO 1400 IP2 = I + 2 IM1 = I - 1 GO TO 1500 C 1300 CONTINUE IP2 = 3 IM1 = 144 GO TO 1500 C 1400 CONTINUE IP2 = 2 IM1 = 143 C 1500 CONTINUE IP1 = I + 1 IF (LIN) GO TO 1600 IF ((J.LT.2).OR.(J.GE.36)) XJ2TM=0. C.....DO NOT ALLOW POINT OFF GRID IF (IP2.LT.1) IP2 = 1 IF (IM1.LT.1) IM1 = 1 IF (IP2.GT.145) IP2 = 145 IF (IM1.GT.145) IM1 = 145 C 1600 CONTINUE C.....DO NOT ALLOW POINT OFF GRID IF (I.LT.1) I = 1 IF (IP1.LT.1) IP1 = 1 IF (I.GT.145) I = 145 IF (IP1.GT.145) IP1 = 145 C 1700 CONTINUE IF (.NOT.LIN) GO TO 1900 C C LINEAR INTERPLOATION C DO 1800 K = 2,3 J1 = JY(K) IF (J1.LT.1) J1 = 1 IF (J1.GT.37) J1 = 37 ERAS(K) = (ALOLA(IP1,J1) - ALOLA(I,J1)) * XDELI + ALOLA(I,J1) 1800 CONTINUE C APOLA(KK) = ERAS(2) + (ERAS(3) - ERAS(2)) * XDELJ GO TO 2100 C 1900 CONTINUE C C QUADRATIC INTERPOLATION C DO 2000 K = 1,4 J1 = JY(K) C.....DO NOT ALLOW POINT OFF GRID IF (J1.LT.1) J1 = 1 IF (J1.GT.37) J1 = 37 ERAS(K) = (ALOLA(IP1,J1)-ALOLA(I,J1))*XDELI+ALOLA(I,J1)+ & (ALOLA(IM1,J1)-ALOLA(I,J1)-ALOLA(IP1,J1)+ & ALOLA(IP2,J1))*XI2TM 2000 CONTINUE C APOLA(KK) = ERAS(2)+(ERAS(3)-ERAS(2))*XDELJ+(ERAS(1)- & ERAS(2)-ERAS(3)+ERAS(4)) * XJ2TM C 2100 CONTINUE C C SET POLE POINT , WMO STANDARD FOR U OR V C APOLA(2113) = ALOLA(73,37) C RETURN END