SUBROUTINE W3FT06V(ALOLA,APOLA,INTERP) C$$$ SUBROUTINE DOCUMENTATION BLOCK *** C C SUBROUTINE: W3FT06V CONVERT (145,37) GRID TO (65,65) S. HEMI. GRID C AUTHOR: JONES,R.E. ORG: W342 DATE: 85-04-10 C C ABSTRACT: CONVERT A SOUTHERN 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. S. , THE MESH C LENGTH IS 381 KM. AND THE ORIENTION IS 260 DEG. W. C C PROGRAM HISTORY LOG: C 85-04-10 R.E.JONES VECTORIZED VERSION OF W3FT05 C 89-10-21 R.E.JONES CHANGES TO INCREASE SPEED C 91-07-24 R.E.JONES CHANGE TO CRAY CFT77 FORTRAN C 93-05-31 R.E.JONES RECOMPILE SO LINEAR INTERPOLATION WORKS C C USAGE: CALL W3FT06V(ALOLA,APOLA,INTERP) C C INPUT ARGUMENTS: ALOLA - 145*37 GID 2.5 LAT,LON GRID S. HEMISHERE C 5365 POINT GRID IS O.N.84 TYPE 30 OR 1E HEX C INTERP - 1 LINEAR INTERPOLATION , NE.1 BIQUADRATIC C C INPUT FILES: NONE C C OUTPUT ARGUMENTS: APOLA - 65*65 GRID OF NORTHERN HEMI. C 4225 POINT GRID IS O.N.84 TYPE 28 OR 1C HEX C C OUTPUT FILES: ERROR MESSAGE TO FORTRAN OUTPUT FILE C C WARNINGS: C C 1. W1 AND W2 ARE USED TO STORE SETS OF CONSTANTS WHICH ARE C REUSABLE FOR REPEATED CALLS TO THE SUBROUTINE. C C 2. WIND COMPONENTS ARE NOT ROTATED TO THE 65*65 GRID ORIENTATION C AFTER INTERPOLATION. YOU MAY USE W3FC10 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 RETURN CONDITIONS: NORMAL SUBROUTINE EXIT C C SUBPROGRAMS CALLED: C UNIQUE : NONE C C LIBRARY: ASIN , ATAN2 C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN C MACHINE: CRAY Y-MP8/864 C C$$$ C REAL R2(4225), WLON(4225) REAL XLAT(4225), XI(65,65), XJ(65,65) REAL XII(4225), XJJ(4225), ANGLE(4225) REAL ALOLA(145,37), APOLA(4225), ERAS(4225,4) REAL W1(4225), W2(4225) REAL XDELI(4225), XDELJ(4225) REAL XI2TM(4225), XJ2TM(4225) C INTEGER IV(4225), JV(4225), JY(4225,4) INTEGER IM1(4225), IP1(4225), IP2(4225) C LOGICAL LIN C SAVE C EQUIVALENCE (XI(1,1),XII(1)),(XJ(1,1),XJJ(1)) C DATA DEGPRD/57.2957795/ DATA EARTHR/6371.2/ DATA INTRPO/99/ DATA ISWT /0/ C LIN = .FALSE. IF (INTERP.EQ.1) LIN = .TRUE. IF (ISWT.EQ.1) GO TO 900 C ORIENT = 260.0 DEG = 2.5 XMESH = 381.0 GI2 = (1.86603 * EARTHR) / XMESH GI2 = GI2 * GI2 C C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB03 IN LINE C DO 100 J = 1,65 XJ1 = J - 33 DO 100 I = 1,65 XI(I,J) = I - 33 XJ(I,J) = XJ1 100 CONTINUE C DO 200 KK = 1,4225 R2(KK) = XJJ(KK) * XJJ(KK) + XII(KK) * XII(KK) XLAT(KK) = -DEGPRD * & ASIN((GI2 - R2(KK)) / (GI2 + R2(KK))) 200 CONTINUE C XII(2113) = 1.0 DO 300 KK = 1,4225 ANGLE(KK) = DEGPRD * ATAN2(XJJ(KK),XII(KK)) 300 CONTINUE C DO 400 KK = 1,4225 IF (ANGLE(KK).LT.0.0) ANGLE(KK) = ANGLE(KK) + 360.0 400 CONTINUE C DO 500 KK = 1,4225 WLON(KK) = ANGLE(KK) + ORIENT - 270.0 500 CONTINUE C DO 600 KK = 1,4225 IF (WLON(KK).GE.360.0) WLON(KK) = WLON(KK) - 360.0 600 CONTINUE C DO 700 KK = 1,4225 IF (WLON(KK).LT.0.0) WLON(KK) = WLON(KK) + 360.0 700 CONTINUE C XLAT(2113) = -90.0 WLON(2113) = 0.0 C DO 800 KK = 1,4225 W1(KK) = (360.0 - WLON(KK)) / DEG + 1.0 W2(KK) = (XLAT(KK) + 90.0) / DEG + 1.0 800 CONTINUE C ISWT = 1 INTRPO = INTERP GO TO 1000 C C AFTER THE 1ST CALL TO W3FT05 TEST INTERP, IF IT HAS C CHANGED RECOMPUTE SOME CONSTANTS C 900 CONTINUE IF (INTERP.EQ.INTRPO) GO TO 2100 INTRPO = INTERP C 1000 CONTINUE DO 1100 K = 1,4225 IV(K) = W1(K) JV(K) = W2(K) XDELI(K) = W1(K) - IV(K) XDELJ(K) = W2(K) - JV(K) IP1(K) = IV(K) + 1 JY(K,3) = JV(K) + 1 JY(K,2) = JV(K) 1100 CONTINUE C IF (LIN) GO TO 1400 C DO 1200 K = 1,4225 IP2(K) = IV(K) + 2 IM1(K) = IV(K) - 1 JY(K,1) = JV(K) - 1 JY(K,4) = JV(K) + 2 XI2TM(K) = XDELI(K) * (XDELI(K) - 1.0) * .25 XJ2TM(K) = XDELJ(K) * (XDELJ(K) - 1.0) * .25 1200 CONTINUE C DO 1300 KK = 1,4225 IF (IV(KK).EQ.1) THEN IP2(KK) = 3 IM1(KK) = 144 ELSE IF (IV(KK).EQ.144) THEN IP2(KK) = 2 IM1(KK) = 143 ENDIF 1300 CONTINUE C 1400 CONTINUE C IF (LIN) GO TO 1700 C DO 1500 KK = 1,4225 IF (JV(KK).LT.2.OR.JV(KK).GT.35) XJ2TM(KK) = 0.0 1500 CONTINUE C DO 1600 KK = 1,4225 IF (IP2(KK).LT.1) IP2(KK) = 1 IF (IM1(KK).LT.1) IM1(KK) = 1 IF (IP2(KK).GT.145) IP2(KK) = 145 IF (IM1(KK).GT.145) IM1(KK) = 145 1600 CONTINUE C 1700 CONTINUE DO 1800 KK = 1,4225 IF (IV(KK).LT.1) IV(KK) = 1 IF (IP1(KK).LT.1) IP1(KK) = 1 IF (IV(KK).GT.145) IV(KK) = 145 IF (IP1(KK).GT.145) IP1(KK) = 145 1800 CONTINUE C C LINEAR INTERPOLATION C DO 1900 KK = 1,4225 IF (JY(KK,2).LT.1) JY(KK,2) = 1 IF (JY(KK,2).GT.37) JY(KK,2) = 37 IF (JY(KK,3).LT.1) JY(KK,3) = 1 IF (JY(KK,3).GT.37) JY(KK,3) = 37 1900 CONTINUE C IF (.NOT.LIN) THEN DO 2000 KK = 1,4225 IF (JY(KK,1).LT.1) JY(KK,1) = 1 IF (JY(KK,1).GT.37) JY(KK,1) = 37 IF (JY(KK,4).LT.1) JY(KK,4) = 1 IF (JY(KK,4).GT.37) JY(KK,4) = 37 2000 CONTINUE ENDIF C 2100 CONTINUE IF (LIN) THEN C C LINEAR INTERPOLATION C DO 2200 KK = 1,4225 ERAS(KK,2) = (ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) ERAS(KK,3) = (ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) 2200 CONTINUE C DO 2300 KK = 1,4225 APOLA(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) & * XDELJ(KK) 2300 CONTINUE C ELSE C C QUADRATIC INTERPOLATION C DO 2400 KK = 1,4225 ERAS(KK,1)=(ALOLA(IP1(KK),JY(KK,1))-ALOLA(IV(KK),JY(KK,1))) & * XDELI(KK) + ALOLA(IV(KK),JY(KK,1)) + & ( ALOLA(IM1(KK),JY(KK,1)) - ALOLA(IV(KK),JY(KK,1)) & - ALOLA(IP1(KK),JY(KK,1))+ALOLA(IP2(KK),JY(KK,1))) & * XI2TM(KK) ERAS(KK,2)=(ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) + & ( ALOLA(IM1(KK),JY(KK,2)) - ALOLA(IV(KK),JY(KK,2)) & - ALOLA(IP1(KK),JY(KK,2))+ALOLA(IP2(KK),JY(KK,2))) & * XI2TM(KK) ERAS(KK,3)=(ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) + & ( ALOLA(IM1(KK),JY(KK,3)) - ALOLA(IV(KK),JY(KK,3)) & - ALOLA(IP1(KK),JY(KK,3))+ALOLA(IP2(KK),JY(KK,3))) & * XI2TM(KK) ERAS(KK,4)=(ALOLA(IP1(KK),JY(KK,4))-ALOLA(IV(KK),JY(KK,4))) & * XDELI(KK) + ALOLA(IV(KK),JY(KK,4)) + & ( ALOLA(IM1(KK),JY(KK,4)) - ALOLA(IV(KK),JY(KK,4)) & - ALOLA(IP1(KK),JY(KK,4))+ALOLA(IP2(KK),JY(KK,4))) & * XI2TM(KK) 2400 CONTINUE C DO 2500 KK = 1,4225 APOLA(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) & * XDELJ(KK) + (ERAS(KK,1) - ERAS(KK,2) & - ERAS(KK,3) + ERAS(KK,4)) * XJ2TM(KK) 2500 CONTINUE C ENDIF C C SET POLE POINT , WMO STANDARD FOR U OR V C APOLA(2113) = ALOLA(73,1) C RETURN END