SUBROUTINE W3FT06(ALOLA,APOLA,W1,W2,LINEAR)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: W3FT06 CONVERT (145,37) TO (65,65) S. HEMI. GRID
C AUTHOR: JONES,R.E. ORG: W342 DATE: 84-06-18
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.(100E) .
C
C PROGRAM HISTORY LOG:
C 84-06-18 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 W3FT06(ALOLA,APOLA,W1,W2,LINEAR)
C
C INPUT VARIABLES:
C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C ------ --------- -----------------------------------------------
C ALOLA ARG LIST 145*37 DEG 2.5 LAT,LON GRID S. HEMI.
C 5365 POINT GRID IS TYPE 30 OR 1E 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 SOUTHERN HEMI.
C 4225 POINT GRID IS TYPE 28 OR 1C HEX O.N. 84
C W1 ARG LIST 65*65 SCRATCH FIELD
C W2 ARG LIST 65*65 SCRATCH FIELD
C FT06F001 ERROR MESSAGE
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 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 4. YOU SHOULD USE THE CRAY VECTORIZED VERION W3FT06V ON THE CRAY
C IT HAS 3 PARAMETERS IN THE CALL, RUNS ABOUT TIMES FASTER, USES
C MORE MEMORY.
C
C ATTRIBUTES:
C LANGUAGE: CRAY CFT77 FORTRAN
C MACHINE: CRAY Y-MP8/864
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 W3FT06 ***)
C
LIN = .FALSE.
IF (LINEAR.EQ.1) LIN = .TRUE.
IF (ISWT.EQ.0) GO TO 300
C
C TEST TO SEE IF W1 OR W2 WAS 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
GO TO 800
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 600 PUTS SUBROUTINE W3FB03 IN LINE
C
DO 600 J=1,65
XJ = J - 33
XJ2 = XJ * XJ
DO 600 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 500
400 CONTINUE
XLONG = DEGPRD * ATAN2(XJ,XI)
WLON = XLONG -10.0
IF (WLON.LT.0.0) WLON = WLON + 360.0
XLAT = ASIN((GI2-R2)/(GI2+R2))*DEGPRD
XLAT = -XLAT
500 CONTINUE
XLAT = XLAT + 90.0
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
600 CONTINUE
C
DO 700 KK=1,10
SAVEW1(KK)=W1(KK)
SAVEW2(KK)=W2(KK)
700 CONTINUE
C
ISWT = 1
C
800 CONTINUE
C
DO 1900 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 900
IP2 = I + 2
IM1 = I - 1
JY(4) = J + 2
JY(1) = J - 1
XI2TM = XDELI*(XDELI-1.)*.25
XJ2TM = XDELJ*(XDELJ-1.)*.25
900 CONTINUE
IF ((I.LT.2).OR.(J.LT.2)) GO TO 1000
IF ((I.GT.142).OR.(J.GT.34)) GO TO 1000
C QUADRATIC (LINEAR TOO) OK W/O FURTHER ADO SO GO TO 1500
GO TO 1500
C
1000 CONTINUE
IF (I.EQ.1) GO TO 1100
IF (I.EQ.144) GO TO 1200
IP2 = I+2
IM1 = I-1
GO TO 1300
C
1100 CONTINUE
IP2 = 3
IM1 = 144
GO TO 1300
C
1200 CONTINUE
IP2 = 2
IM1 = 143
C
1300 CONTINUE
IP1 = I + 1
IF (LIN) GO TO 1400
IF ((J.LT.2).OR.(J.GE.36)) XJ2TM=0.
C.....DO NOT ALLOW POINT OFF GRID,CYCLIC OR NOT
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
1400 CONTINUE
C.....DO NOT ALLOW POINT OFF GRID,CYCLIC OR NOT
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
1500 CONTINUE
C
IF (.NOT.LIN) GO TO 1700
C
C LINEAR INTERPOLATION
C
DO 1600 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)
1600 CONTINUE
C
APOLA(KK) = ERAS(2) + (ERAS(3) - ERAS(2)) * XDELJ
GO TO 1900
C
1700 CONTINUE
C
C QUADRATIC INTERPOLATION
C
DO 1800 K = 1,4
J1 = JY(K)
C.....DO NOT ALLOW POINT OFF GRID,CYCLIC OR NOT
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
1800 CONTINUE
C
APOLA(KK) = ERAS(2)+(ERAS(3)-ERAS(2))*XDELJ+(ERAS(1)-
& ERAS(2)-ERAS(3)+ERAS(4))*XJ2TM
C
1900 CONTINUE
C
C SET POLE POINT, WMO STANDARD FOR U OR V
C
APOLA(2113) = ALOLA(73,1)
C
RETURN
END