)
@@ -48,9 +62,6 @@ foreach(kind ${kinds})
if(OpenMP_Fortran_FOUND)
target_link_libraries(${lib_name} PUBLIC OpenMP::OpenMP_Fortran)
endif()
-
- # Link to sp library.
- target_link_libraries(${lib_name} PUBLIC sp::sp_${kind})
list(APPEND LIB_TARGETS ${lib_name})
diff --git a/src/fftpack.F b/src/fftpack.F
new file mode 100644
index 00000000..bb415a6a
--- /dev/null
+++ b/src/fftpack.F
@@ -0,0 +1,1337 @@
+C> @file
+C> @brief A concatination of the (FFTPACK)[https://netlib.org/fftpack/] library code.
+C>
+C> FFTPACK is a package of Fortran subprograms for the fast Fourier
+C> transform of periodic and other symmetric sequences. It includes
+C> complex, real, sine, cosine, and quarter-wave transforms.
+C>
+C>Reference:
+C>- P.N. Swarztrauber, Vectorizing the FFTs, in Parallel Computations
+C>(G. Rodrigue, ed.), Academic Press, 1982, pp. 51--83.
+C>
+C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO
+
+C> dcrft
+C>
+C> @param init
+C> @param x
+C> @param ldx
+C> @param y
+C> @param ldy
+C> @param n
+C> @param m
+C> @param isign
+C> @param scale
+C> @param table
+C> @param n1
+C> @param wrk
+C> @param n2
+C> @param z
+C> @param nz
+C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO
+ SUBROUTINE dcrft(init,x,ldx,y,ldy,n,m,isign,scale,
+ & table,n1,wrk,n2,z,nz)
+
+ implicit none
+ integer init,ldx,ldy,n,m,isign,n1,n2,nz,i,j
+ real x(2*ldx,*),y(ldy,*),scale,table(44002),wrk,z
+
+ IF (init.ne.0) THEN
+ CALL rffti(n,table)
+ ELSE
+!OCL NOVREC
+ DO j=1,m
+ y(1,j)=x(1,j)
+ DO i=2,n
+ y(i,j)=x(i+1,j)
+ ENDDO
+ CALL rfftb(n,y(1,j),table)
+ DO i=1,n
+ y(i,j)=scale*y(i,j)
+ ENDDO
+ ENDDO
+ ENDIF
+
+ RETURN
+ END
+
+C> scrft
+C>
+C> @param init
+C> @param x
+C> @param ldx
+C> @param y
+C> @param ldy
+C> @param n
+C> @param m
+C> @param isign
+C> @param scale
+C> @param table
+C> @param n1
+C> @param wrk
+C> @param n2
+C> @param z
+C> @param nz
+C>
+C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO
+
+ SUBROUTINE scrft(init,x,ldx,y,ldy,n,m,isign,scale,
+ & table,n1,wrk,n2,z,nz)
+
+ implicit none
+ integer init,ldx,ldy,n,m,isign,n1,n2,nz,i,j
+ real x(2*ldx,*),y(ldy,*),scale,table(44002),wrk,z
+
+ IF (init.ne.0) THEN
+ CALL rffti(n,table)
+ ELSE
+!OCL NOVREC
+ DO j=1,m
+ y(1,j)=x(1,j)
+ DO i=2,n
+ y(i,j)=x(i+1,j)
+ ENDDO
+ CALL rfftb(n,y(1,j),table)
+ DO i=1,n
+ y(i,j)=scale*y(i,j)
+ ENDDO
+ ENDDO
+ ENDIF
+
+ RETURN
+ END
+
+C> csfft
+C>
+C> @param isign
+C> @param n
+C> @param scale
+C> @param x
+C> @param y
+C> @param table
+C> @param work
+C> @param isys
+C>
+C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO
+ SUBROUTINE csfft(isign,n,scale,x,y,table,work,isys)
+
+ implicit none
+ integer isign,n,isys,i
+ real scale,x(*),y(*),table(*),work(*)
+
+ IF (isign.eq.0) THEN
+ CALL rffti(n,table)
+ ENDIF
+ IF (isign.eq.1) THEN
+ y(1)=x(1)
+ DO i=2,n
+ y(i)=x(i+1)
+ ENDDO
+ CALL rfftb(n,y,table)
+ DO i=1,n
+ y(i)=scale*y(i)
+ ENDDO
+ ENDIF
+
+ RETURN
+ END
+
+C> drcft
+C>
+C> @param init
+C> @param x
+C> @param ldx
+C> @param y
+C> @param ldy
+C> @param n
+C> @param m
+C> @param isign
+C> @param scale
+C> @param table
+C> @param n1
+C> @param wrk
+C> @param n2
+C> @param z
+C> @param nz
+C>
+C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO
+ SUBROUTINE drcft(init,x,ldx,y,ldy,n,m,isign,scale,
+ & table,n1,wrk,n2,z,nz)
+
+ implicit none
+ integer init,ldx,ldy,n,m,isign,n1,n2,nz,i,j
+ real x(ldx,*),y(2*ldy,*),scale,table(44002),wrk,z
+
+ IF (init.ne.0) THEN
+ CALL rffti(n,table)
+ ELSE
+ DO j=1,m
+ DO i=1,n
+ y(i,j)=x(i,j)
+ ENDDO
+ CALL rfftf(n,y(1,j),table)
+ DO i=1,n
+ y(i,j)=scale*y(i,j)
+ ENDDO
+ DO i=n,2,-1
+ y(i+1,j)=y(i,j)
+ ENDDO
+ y(2,j)=0.
+C 01/17/2013 vvvvvvvvvvvvv E.Mirvis added ver 2.0.1 by S.Moorthi request. No +|- demo.
+ y(n+2,j) = 0.
+ ENDDO
+ ENDIF
+
+ RETURN
+ END
+
+C> srcft
+C>
+C> @param init
+C> @param x
+C> @param ldx
+C> @param y
+C> @param ldy
+C> @param n
+C> @param m
+C> @param isign
+C> @param scale
+C> @param table
+C> @param n1
+C> @param wrk
+C> @param n2
+C> @param z
+C> @param nz
+C>
+C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO
+ SUBROUTINE srcft(init,x,ldx,y,ldy,n,m,isign,scale,
+ & table,n1,wrk,n2,z,nz)
+
+ implicit none
+ integer init,ldx,ldy,n,m,isign,n1,n2,nz,i,j
+ real x(ldx,*),y(2*ldy,*),scale,table(44002),wrk,z
+
+ IF (init.ne.0) THEN
+ CALL rffti(n,table)
+ ELSE
+ DO j=1,m
+ DO i=1,n
+ y(i,j)=x(i,j)
+ ENDDO
+ CALL rfftf(n,y(1,j),table)
+ DO i=1,n
+ y(i,j)=scale*y(i,j)
+ ENDDO
+ DO i=n,2,-1
+ y(i+1,j)=y(i,j)
+ ENDDO
+ y(2,j)=0.
+ y(n+2,j) = 0.
+C 01/17/2013 ^^^^^^^^^^E.Mirvis added ver 2.0.1 by S.Moorthi request. No +|- demo.
+ ENDDO
+ ENDIF
+
+ RETURN
+ END
+
+C> scfft
+C>
+C> @param isign
+C> @param n
+C> @param scale
+C> @param x
+C> @param y
+C> @param table
+C> @param work
+C> @param isys
+C>
+C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO
+ SUBROUTINE scfft(isign,n,scale,x,y,table,work,isys)
+
+ implicit none
+ integer isign,n,isys,i
+ real scale,x(*),y(*),table(*),work(*)
+
+ IF (isign.eq.0) THEN
+ CALL rffti(n,table)
+ ENDIF
+ IF (isign.eq.-1) THEN
+ DO i=1,n
+ y(i)=x(i)
+ ENDDO
+ CALL rfftf(n,y,table)
+ DO i=1,n
+ y(i)=scale*y(i)
+ ENDDO
+ DO i=n,2,-1
+ y(i+1)=y(i)
+ ENDDO
+ y(2)=0.
+ ENDIF
+
+ RETURN
+ END
+
+C> RFFTF
+C>
+C> @param N
+C> @param R
+C> @param WSAVE
+C>
+C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO
+ SUBROUTINE RFFTF (N,R,WSAVE)
+ DIMENSION R(1) ,WSAVE(1)
+ IF (N .EQ. 1) RETURN
+ CALL RFFTF1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1))
+ RETURN
+ END
+
+C> RFFTB
+C>
+C> @param N
+C> @param R
+C> @param WSAVE
+C>
+C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO
+ SUBROUTINE RFFTB (N,R,WSAVE)
+ DIMENSION R(1) ,WSAVE(1)
+ IF (N .EQ. 1) RETURN
+ CALL RFFTB1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1))
+ RETURN
+ END
+
+C> RFFTI
+C>
+C> @param N
+C> @param WSAVE
+C>
+C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO
+ SUBROUTINE RFFTI (N,WSAVE)
+ DIMENSION WSAVE(1)
+ IF (N .EQ. 1) RETURN
+ CALL RFFTI1 (N,WSAVE(N+1),WSAVE(2*N+1))
+ RETURN
+ END
+
+C> RFFTB1
+C>
+C> @param N
+C> @param C
+C> @param CH
+C> @param WA
+C> @param IFAC
+C>
+C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO
+ SUBROUTINE RFFTB1 (N,C,CH,WA,IFAC)
+ DIMENSION CH(1) ,C(1) ,WA(1) ,IFAC(*)
+ NF = IFAC(2)
+ NA = 0
+ L1 = 1
+ IW = 1
+ DO 116 K1=1,NF
+ IP = IFAC(K1+2)
+ L2 = IP*L1
+ IDO = N/L2
+ IDL1 = IDO*L1
+ IF (IP .NE. 4) GO TO 103
+ IX2 = IW+IDO
+ IX3 = IX2+IDO
+ IF (NA .NE. 0) GO TO 101
+ CALL RADB4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
+ GO TO 102
+ 101 CALL RADB4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
+ 102 NA = 1-NA
+ GO TO 115
+ 103 IF (IP .NE. 2) GO TO 106
+ IF (NA .NE. 0) GO TO 104
+ CALL RADB2 (IDO,L1,C,CH,WA(IW))
+ GO TO 105
+ 104 CALL RADB2 (IDO,L1,CH,C,WA(IW))
+ 105 NA = 1-NA
+ GO TO 115
+ 106 IF (IP .NE. 3) GO TO 109
+ IX2 = IW+IDO
+ IF (NA .NE. 0) GO TO 107
+ CALL RADB3 (IDO,L1,C,CH,WA(IW),WA(IX2))
+ GO TO 108
+ 107 CALL RADB3 (IDO,L1,CH,C,WA(IW),WA(IX2))
+ 108 NA = 1-NA
+ GO TO 115
+ 109 IF (IP .NE. 5) GO TO 112
+ IX2 = IW+IDO
+ IX3 = IX2+IDO
+ IX4 = IX3+IDO
+ IF (NA .NE. 0) GO TO 110
+ CALL RADB5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
+ GO TO 111
+ 110 CALL RADB5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
+ 111 NA = 1-NA
+ GO TO 115
+ 112 IF (NA .NE. 0) GO TO 113
+ CALL RADBG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
+ GO TO 114
+ 113 CALL RADBG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
+ 114 IF (IDO .EQ. 1) NA = 1-NA
+ 115 L1 = L2
+ IW = IW+(IP-1)*IDO
+ 116 CONTINUE
+ IF (NA .EQ. 0) RETURN
+ DO 117 I=1,N
+ C(I) = CH(I)
+ 117 CONTINUE
+ RETURN
+ END
+
+C> RFFTF1
+C>
+C> @param N
+C> @param C
+C> @param CH
+C> @param WA
+C> @param IFAC
+C>
+C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO
+ SUBROUTINE RFFTF1 (N,C,CH,WA,IFAC)
+ DIMENSION CH(1) ,C(1) ,WA(1) ,IFAC(*)
+ NF = IFAC(2)
+ NA = 1
+ L2 = N
+ IW = N
+ DO 111 K1=1,NF
+ KH = NF-K1
+ IP = IFAC(KH+3)
+ L1 = L2/IP
+ IDO = N/L2
+ IDL1 = IDO*L1
+ IW = IW-(IP-1)*IDO
+ NA = 1-NA
+ IF (IP .NE. 4) GO TO 102
+ IX2 = IW+IDO
+ IX3 = IX2+IDO
+ IF (NA .NE. 0) GO TO 101
+ CALL RADF4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
+ GO TO 110
+ 101 CALL RADF4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
+ GO TO 110
+ 102 IF (IP .NE. 2) GO TO 104
+ IF (NA .NE. 0) GO TO 103
+ CALL RADF2 (IDO,L1,C,CH,WA(IW))
+ GO TO 110
+ 103 CALL RADF2 (IDO,L1,CH,C,WA(IW))
+ GO TO 110
+ 104 IF (IP .NE. 3) GO TO 106
+ IX2 = IW+IDO
+ IF (NA .NE. 0) GO TO 105
+ CALL RADF3 (IDO,L1,C,CH,WA(IW),WA(IX2))
+ GO TO 110
+ 105 CALL RADF3 (IDO,L1,CH,C,WA(IW),WA(IX2))
+ GO TO 110
+ 106 IF (IP .NE. 5) GO TO 108
+ IX2 = IW+IDO
+ IX3 = IX2+IDO
+ IX4 = IX3+IDO
+ IF (NA .NE. 0) GO TO 107
+ CALL RADF5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
+ GO TO 110
+ 107 CALL RADF5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
+ GO TO 110
+ 108 IF (IDO .EQ. 1) NA = 1-NA
+ IF (NA .NE. 0) GO TO 109
+ CALL RADFG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
+ NA = 1
+ GO TO 110
+ 109 CALL RADFG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
+ NA = 0
+ 110 L2 = L1
+ 111 CONTINUE
+ IF (NA .EQ. 1) RETURN
+ DO 112 I=1,N
+ C(I) = CH(I)
+ 112 CONTINUE
+ RETURN
+ END
+
+C> RFFTI1
+C>
+C> @param N
+C> @param WA
+C> @param IFAC
+C>
+C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO
+ SUBROUTINE RFFTI1 (N,WA,IFAC)
+ DIMENSION WA(1) ,IFAC(*) ,NTRYH(4)
+ DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/
+ NL = N
+ NF = 0
+ J = 0
+ 101 J = J+1
+ IF (J-4) 102,102,103
+ 102 NTRY = NTRYH(J)
+ GO TO 104
+ 103 NTRY = NTRY+2
+ 104 NQ = NL/NTRY
+ NR = NL-NTRY*NQ
+ IF (NR) 101,105,101
+ 105 NF = NF+1
+ IFAC(NF+2) = NTRY
+ NL = NQ
+ IF (NTRY .NE. 2) GO TO 107
+ IF (NF .EQ. 1) GO TO 107
+ DO 106 I=2,NF
+ IB = NF-I+2
+ IFAC(IB+2) = IFAC(IB+1)
+ 106 CONTINUE
+ IFAC(3) = 2
+ 107 IF (NL .NE. 1) GO TO 104
+ IFAC(1) = N
+ IFAC(2) = NF
+ TPI = 6.28318530717959
+ ARGH = TPI/FLOAT(N)
+ IS = 0
+ NFM1 = NF-1
+ L1 = 1
+ IF (NFM1 .EQ. 0) RETURN
+!OCL NOVREC
+ DO 110 K1=1,NFM1
+ IP = IFAC(K1+2)
+ LD = 0
+ L2 = L1*IP
+ IDO = N/L2
+ IPM = IP-1
+ DO 109 J=1,IPM
+ LD = LD+L1
+ I = IS
+ ARGLD = FLOAT(LD)*ARGH
+ FI = 0
+!OCL SCALAR
+ DO 108 II=3,IDO,2
+ I = I+2
+ FI = FI+1
+ ARG = FI*ARGLD
+ WA(I-1) = COS(ARG)
+ WA(I) = SIN(ARG)
+ 108 CONTINUE
+ IS = IS+IDO
+ 109 CONTINUE
+ L1 = L2
+ 110 CONTINUE
+ RETURN
+ END
+
+C> RADB2
+C>
+C> @param IDO
+C> @param L1
+C> @param CC
+C> @param CH
+C> @param WA1
+C>
+C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO
+ SUBROUTINE RADB2 (IDO,L1,CC,CH,WA1)
+ DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2) ,
+ 1 WA1(1)
+ DO 101 K=1,L1
+ CH(1,K,1) = CC(1,1,K)+CC(IDO,2,K)
+ CH(1,K,2) = CC(1,1,K)-CC(IDO,2,K)
+ 101 CONTINUE
+ IF (IDO-2) 107,105,102
+ 102 IDP2 = IDO+2
+!OCL NOVREC
+ DO 104 K=1,L1
+ DO 103 I=3,IDO,2
+ IC = IDP2-I
+ CH(I-1,K,1) = CC(I-1,1,K)+CC(IC-1,2,K)
+ TR2 = CC(I-1,1,K)-CC(IC-1,2,K)
+ CH(I,K,1) = CC(I,1,K)-CC(IC,2,K)
+ TI2 = CC(I,1,K)+CC(IC,2,K)
+ CH(I-1,K,2) = WA1(I-2)*TR2-WA1(I-1)*TI2
+ CH(I,K,2) = WA1(I-2)*TI2+WA1(I-1)*TR2
+ 103 CONTINUE
+ 104 CONTINUE
+ IF (MOD(IDO,2) .EQ. 1) RETURN
+ 105 DO 106 K=1,L1
+ CH(IDO,K,1) = CC(IDO,1,K)+CC(IDO,1,K)
+ CH(IDO,K,2) = -(CC(1,2,K)+CC(1,2,K))
+ 106 CONTINUE
+ 107 RETURN
+ END
+
+C> RADB3
+C>
+C> @param IDO
+C> @param L1
+C> @param CC
+C> @param CH
+C> @param WA1
+C> @param WA2
+C>
+C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO
+ SUBROUTINE RADB3 (IDO,L1,CC,CH,WA1,WA2)
+ DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3) ,
+ 1 WA1(1) ,WA2(1)
+ DATA TAUR,TAUI /-.5,.866025403784439/
+ DO 101 K=1,L1
+ TR2 = CC(IDO,2,K)+CC(IDO,2,K)
+ CR2 = CC(1,1,K)+TAUR*TR2
+ CH(1,K,1) = CC(1,1,K)+TR2
+ CI3 = TAUI*(CC(1,3,K)+CC(1,3,K))
+ CH(1,K,2) = CR2-CI3
+ CH(1,K,3) = CR2+CI3
+ 101 CONTINUE
+ IF (IDO .EQ. 1) RETURN
+ IDP2 = IDO+2
+!OCL NOVREC
+ DO 103 K=1,L1
+ DO 102 I=3,IDO,2
+ IC = IDP2-I
+ TR2 = CC(I-1,3,K)+CC(IC-1,2,K)
+ CR2 = CC(I-1,1,K)+TAUR*TR2
+ CH(I-1,K,1) = CC(I-1,1,K)+TR2
+ TI2 = CC(I,3,K)-CC(IC,2,K)
+ CI2 = CC(I,1,K)+TAUR*TI2
+ CH(I,K,1) = CC(I,1,K)+TI2
+ CR3 = TAUI*(CC(I-1,3,K)-CC(IC-1,2,K))
+ CI3 = TAUI*(CC(I,3,K)+CC(IC,2,K))
+ DR2 = CR2-CI3
+ DR3 = CR2+CI3
+ DI2 = CI2+CR3
+ DI3 = CI2-CR3
+ CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2
+ CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2
+ CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3
+ CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3
+ 102 CONTINUE
+ 103 CONTINUE
+ RETURN
+ END
+
+C> RADB4
+C>
+C> @param IDO
+C> @param L1
+C> @param CC
+C> @param CH
+C> @param WA1
+C> @param WA2
+C> @param WA3
+C>
+C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO
+ SUBROUTINE RADB4 (IDO,L1,CC,CH,WA1,WA2,WA3)
+ DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4) ,
+ 1 WA1(1) ,WA2(1) ,WA3(1)
+ DATA SQRT2 /1.414213562373095/
+ DO 101 K=1,L1
+ TR1 = CC(1,1,K)-CC(IDO,4,K)
+ TR2 = CC(1,1,K)+CC(IDO,4,K)
+ TR3 = CC(IDO,2,K)+CC(IDO,2,K)
+ TR4 = CC(1,3,K)+CC(1,3,K)
+ CH(1,K,1) = TR2+TR3
+ CH(1,K,2) = TR1-TR4
+ CH(1,K,3) = TR2-TR3
+ CH(1,K,4) = TR1+TR4
+ 101 CONTINUE
+ IF (IDO-2) 107,105,102
+ 102 IDP2 = IDO+2
+!OCL NOVREC
+ DO 104 K=1,L1
+ DO 103 I=3,IDO,2
+ IC = IDP2-I
+ TI1 = CC(I,1,K)+CC(IC,4,K)
+ TI2 = CC(I,1,K)-CC(IC,4,K)
+ TI3 = CC(I,3,K)-CC(IC,2,K)
+ TR4 = CC(I,3,K)+CC(IC,2,K)
+ TR1 = CC(I-1,1,K)-CC(IC-1,4,K)
+ TR2 = CC(I-1,1,K)+CC(IC-1,4,K)
+ TI4 = CC(I-1,3,K)-CC(IC-1,2,K)
+ TR3 = CC(I-1,3,K)+CC(IC-1,2,K)
+ CH(I-1,K,1) = TR2+TR3
+ CR3 = TR2-TR3
+ CH(I,K,1) = TI2+TI3
+ CI3 = TI2-TI3
+ CR2 = TR1-TR4
+ CR4 = TR1+TR4
+ CI2 = TI1+TI4
+ CI4 = TI1-TI4
+ CH(I-1,K,2) = WA1(I-2)*CR2-WA1(I-1)*CI2
+ CH(I,K,2) = WA1(I-2)*CI2+WA1(I-1)*CR2
+ CH(I-1,K,3) = WA2(I-2)*CR3-WA2(I-1)*CI3
+ CH(I,K,3) = WA2(I-2)*CI3+WA2(I-1)*CR3
+ CH(I-1,K,4) = WA3(I-2)*CR4-WA3(I-1)*CI4
+ CH(I,K,4) = WA3(I-2)*CI4+WA3(I-1)*CR4
+ 103 CONTINUE
+ 104 CONTINUE
+ IF (MOD(IDO,2) .EQ. 1) RETURN
+ 105 CONTINUE
+ DO 106 K=1,L1
+ TI1 = CC(1,2,K)+CC(1,4,K)
+ TI2 = CC(1,4,K)-CC(1,2,K)
+ TR1 = CC(IDO,1,K)-CC(IDO,3,K)
+ TR2 = CC(IDO,1,K)+CC(IDO,3,K)
+ CH(IDO,K,1) = TR2+TR2
+ CH(IDO,K,2) = SQRT2*(TR1-TI1)
+ CH(IDO,K,3) = TI2+TI2
+ CH(IDO,K,4) = -SQRT2*(TR1+TI1)
+ 106 CONTINUE
+ 107 RETURN
+ END
+
+C> RADB5
+C>
+C> @param IDO
+C> @param L1
+C> @param CC
+C> @param CH
+C> @param WA1
+C> @param WA2
+C> @param WA3
+C> @param WA4
+C>
+C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO
+ SUBROUTINE RADB5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4)
+ DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5) ,
+ 1 WA1(1) ,WA2(1) ,WA3(1) ,WA4(1)
+ DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154,
+ 1-.809016994374947,.587785252292473/
+ DO 101 K=1,L1
+ TI5 = CC(1,3,K)+CC(1,3,K)
+ TI4 = CC(1,5,K)+CC(1,5,K)
+ TR2 = CC(IDO,2,K)+CC(IDO,2,K)
+ TR3 = CC(IDO,4,K)+CC(IDO,4,K)
+ CH(1,K,1) = CC(1,1,K)+TR2+TR3
+ CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3
+ CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3
+ CI5 = TI11*TI5+TI12*TI4
+ CI4 = TI12*TI5-TI11*TI4
+ CH(1,K,2) = CR2-CI5
+ CH(1,K,3) = CR3-CI4
+ CH(1,K,4) = CR3+CI4
+ CH(1,K,5) = CR2+CI5
+ 101 CONTINUE
+ IF (IDO .EQ. 1) RETURN
+ IDP2 = IDO+2
+ DO 103 K=1,L1
+ DO 102 I=3,IDO,2
+ IC = IDP2-I
+ TI5 = CC(I,3,K)+CC(IC,2,K)
+ TI2 = CC(I,3,K)-CC(IC,2,K)
+ TI4 = CC(I,5,K)+CC(IC,4,K)
+ TI3 = CC(I,5,K)-CC(IC,4,K)
+ TR5 = CC(I-1,3,K)-CC(IC-1,2,K)
+ TR2 = CC(I-1,3,K)+CC(IC-1,2,K)
+ TR4 = CC(I-1,5,K)-CC(IC-1,4,K)
+ TR3 = CC(I-1,5,K)+CC(IC-1,4,K)
+ CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3
+ CH(I,K,1) = CC(I,1,K)+TI2+TI3
+ CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3
+ CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3
+ CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3
+ CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3
+ CR5 = TI11*TR5+TI12*TR4
+ CI5 = TI11*TI5+TI12*TI4
+ CR4 = TI12*TR5-TI11*TR4
+ CI4 = TI12*TI5-TI11*TI4
+ DR3 = CR3-CI4
+ DR4 = CR3+CI4
+ DI3 = CI3+CR4
+ DI4 = CI3-CR4
+ DR5 = CR2+CI5
+ DR2 = CR2-CI5
+ DI5 = CI2-CR5
+ DI2 = CI2+CR5
+ CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2
+ CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2
+ CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3
+ CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3
+ CH(I-1,K,4) = WA3(I-2)*DR4-WA3(I-1)*DI4
+ CH(I,K,4) = WA3(I-2)*DI4+WA3(I-1)*DR4
+ CH(I-1,K,5) = WA4(I-2)*DR5-WA4(I-1)*DI5
+ CH(I,K,5) = WA4(I-2)*DI5+WA4(I-1)*DR5
+ 102 CONTINUE
+ 103 CONTINUE
+ RETURN
+ END
+
+C> RADBG
+C>
+C> @param IDO
+C> @param IP
+C> @param L1
+C> @param IDL1
+C> @param CC
+C> @param C1
+C> @param C2
+C> @param CH
+C> @param CH2
+C> @param WA
+C>
+C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO
+ SUBROUTINE RADBG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)
+ DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) ,
+ 1 C1(IDO,L1,IP) ,C2(IDL1,IP),
+ 2 CH2(IDL1,IP) ,WA(1)
+ DATA TPI/6.28318530717959/
+ ARG = TPI/FLOAT(IP)
+ DCP = COS(ARG)
+ DSP = SIN(ARG)
+ IDP2 = IDO+2
+ NBD = (IDO-1)/2
+ IPP2 = IP+2
+ IPPH = (IP+1)/2
+ IF (IDO .LT. L1) GO TO 103
+ DO 102 K=1,L1
+ DO 101 I=1,IDO
+ CH(I,K,1) = CC(I,1,K)
+ 101 CONTINUE
+ 102 CONTINUE
+ GO TO 106
+ 103 DO 105 I=1,IDO
+ DO 104 K=1,L1
+ CH(I,K,1) = CC(I,1,K)
+ 104 CONTINUE
+ 105 CONTINUE
+!OCL NOVREC
+ 106 DO 108 J=2,IPPH
+ JC = IPP2-J
+ J2 = J+J
+ DO 107 K=1,L1
+ CH(1,K,J) = CC(IDO,J2-2,K)+CC(IDO,J2-2,K)
+ CH(1,K,JC) = CC(1,J2-1,K)+CC(1,J2-1,K)
+ 107 CONTINUE
+ 108 CONTINUE
+ IF (IDO .EQ. 1) GO TO 116
+ IF (NBD .LT. L1) GO TO 112
+!OCL NOVREC
+ DO 111 J=2,IPPH
+ JC = IPP2-J
+ DO 110 K=1,L1
+ DO 109 I=3,IDO,2
+ IC = IDP2-I
+ CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K)
+ CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K)
+ CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K)
+ CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K)
+ 109 CONTINUE
+ 110 CONTINUE
+ 111 CONTINUE
+ GO TO 116
+ 112 DO 115 J=2,IPPH
+ JC = IPP2-J
+ DO 114 I=3,IDO,2
+ IC = IDP2-I
+ DO 113 K=1,L1
+ CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K)
+ CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K)
+ CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K)
+ CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K)
+ 113 CONTINUE
+ 114 CONTINUE
+ 115 CONTINUE
+ 116 AR1 = 1.
+ AI1 = 0.
+!OCL NOVREC
+ DO 120 L=2,IPPH
+ LC = IPP2-L
+ AR1H = DCP*AR1-DSP*AI1
+ AI1 = DCP*AI1+DSP*AR1
+ AR1 = AR1H
+ DO 117 IK=1,IDL1
+ C2(IK,L) = CH2(IK,1)+AR1*CH2(IK,2)
+ C2(IK,LC) = AI1*CH2(IK,IP)
+ 117 CONTINUE
+ DC2 = AR1
+ DS2 = AI1
+ AR2 = AR1
+ AI2 = AI1
+!OCL NOVREC
+ DO 119 J=3,IPPH
+ JC = IPP2-J
+ AR2H = DC2*AR2-DS2*AI2
+ AI2 = DC2*AI2+DS2*AR2
+ AR2 = AR2H
+ DO 118 IK=1,IDL1
+ C2(IK,L) = C2(IK,L)+AR2*CH2(IK,J)
+ C2(IK,LC) = C2(IK,LC)+AI2*CH2(IK,JC)
+ 118 CONTINUE
+ 119 CONTINUE
+ 120 CONTINUE
+!OCL NOVREC
+ DO 122 J=2,IPPH
+ DO 121 IK=1,IDL1
+ CH2(IK,1) = CH2(IK,1)+CH2(IK,J)
+ 121 CONTINUE
+ 122 CONTINUE
+!OCL NOVREC
+ DO 124 J=2,IPPH
+ JC = IPP2-J
+ DO 123 K=1,L1
+ CH(1,K,J) = C1(1,K,J)-C1(1,K,JC)
+ CH(1,K,JC) = C1(1,K,J)+C1(1,K,JC)
+ 123 CONTINUE
+ 124 CONTINUE
+ IF (IDO .EQ. 1) GO TO 132
+ IF (NBD .LT. L1) GO TO 128
+!OCL NOVREC
+ DO 127 J=2,IPPH
+ JC = IPP2-J
+ DO 126 K=1,L1
+ DO 125 I=3,IDO,2
+ CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC)
+ CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC)
+ CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC)
+ CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC)
+ 125 CONTINUE
+ 126 CONTINUE
+ 127 CONTINUE
+ GO TO 132
+ 128 DO 131 J=2,IPPH
+ JC = IPP2-J
+ DO 130 I=3,IDO,2
+ DO 129 K=1,L1
+ CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC)
+ CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC)
+ CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC)
+ CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC)
+ 129 CONTINUE
+ 130 CONTINUE
+ 131 CONTINUE
+ 132 CONTINUE
+ IF (IDO .EQ. 1) RETURN
+ DO 133 IK=1,IDL1
+ C2(IK,1) = CH2(IK,1)
+ 133 CONTINUE
+ DO 135 J=2,IP
+ DO 134 K=1,L1
+ C1(1,K,J) = CH(1,K,J)
+ 134 CONTINUE
+ 135 CONTINUE
+ IF (NBD .GT. L1) GO TO 139
+ IS = -IDO
+ DO 138 J=2,IP
+ IS = IS+IDO
+ IDIJ = IS
+ DO 137 I=3,IDO,2
+ IDIJ = IDIJ+2
+ DO 136 K=1,L1
+ C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)
+ C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)
+ 136 CONTINUE
+ 137 CONTINUE
+ 138 CONTINUE
+ GO TO 143
+ 139 IS = -IDO
+!OCL NOVREC
+ DO 142 J=2,IP
+ IS = IS+IDO
+ DO 141 K=1,L1
+ IDIJ = IS
+ DO 140 I=3,IDO,2
+ IDIJ = IDIJ+2
+ C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)
+ C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)
+ 140 CONTINUE
+ 141 CONTINUE
+ 142 CONTINUE
+ 143 RETURN
+ END
+
+C> RADBG
+C>
+C> @param IDO
+C> @param L1
+C> @param CC
+C> @param CH
+C> @param WA1
+C>
+C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO
+ SUBROUTINE RADF2 (IDO,L1,CC,CH,WA1)
+ DIMENSION CH(IDO,2,L1) ,CC(IDO,L1,2) ,
+ 1 WA1(1)
+ DO 101 K=1,L1
+ CH(1,1,K) = CC(1,K,1)+CC(1,K,2)
+ CH(IDO,2,K) = CC(1,K,1)-CC(1,K,2)
+ 101 CONTINUE
+ IF (IDO-2) 107,105,102
+ 102 IDP2 = IDO+2
+ DO 104 K=1,L1
+ DO 103 I=3,IDO,2
+ IC = IDP2-I
+ TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
+ TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
+ CH(I,1,K) = CC(I,K,1)+TI2
+ CH(IC,2,K) = TI2-CC(I,K,1)
+ CH(I-1,1,K) = CC(I-1,K,1)+TR2
+ CH(IC-1,2,K) = CC(I-1,K,1)-TR2
+ 103 CONTINUE
+ 104 CONTINUE
+ IF (MOD(IDO,2) .EQ. 1) RETURN
+ 105 DO 106 K=1,L1
+ CH(1,2,K) = -CC(IDO,K,2)
+ CH(IDO,1,K) = CC(IDO,K,1)
+ 106 CONTINUE
+ 107 RETURN
+ END
+
+C> RADF3
+C>
+C> @param IDO
+C> @param L1
+C> @param CC
+C> @param CH
+C> @param WA1
+C> @param WA2
+C>
+C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO
+ SUBROUTINE RADF3 (IDO,L1,CC,CH,WA1,WA2)
+ DIMENSION CH(IDO,3,L1) ,CC(IDO,L1,3) ,
+ 1 WA1(1) ,WA2(1)
+ DATA TAUR,TAUI /-.5,.866025403784439/
+ DO 101 K=1,L1
+ CR2 = CC(1,K,2)+CC(1,K,3)
+ CH(1,1,K) = CC(1,K,1)+CR2
+ CH(1,3,K) = TAUI*(CC(1,K,3)-CC(1,K,2))
+ CH(IDO,2,K) = CC(1,K,1)+TAUR*CR2
+ 101 CONTINUE
+ IF (IDO .EQ. 1) RETURN
+ IDP2 = IDO+2
+ DO 103 K=1,L1
+ DO 102 I=3,IDO,2
+ IC = IDP2-I
+ DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
+ DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
+ DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
+ DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
+ CR2 = DR2+DR3
+ CI2 = DI2+DI3
+ CH(I-1,1,K) = CC(I-1,K,1)+CR2
+ CH(I,1,K) = CC(I,K,1)+CI2
+ TR2 = CC(I-1,K,1)+TAUR*CR2
+ TI2 = CC(I,K,1)+TAUR*CI2
+ TR3 = TAUI*(DI2-DI3)
+ TI3 = TAUI*(DR3-DR2)
+ CH(I-1,3,K) = TR2+TR3
+ CH(IC-1,2,K) = TR2-TR3
+ CH(I,3,K) = TI2+TI3
+ CH(IC,2,K) = TI3-TI2
+ 102 CONTINUE
+ 103 CONTINUE
+ RETURN
+ END
+
+C> RADF4
+C>
+C> @param IDO
+C> @param L1
+C> @param CC
+C> @param CH
+C> @param WA1
+C> @param WA2
+C> @param WA3
+C>
+C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO
+ SUBROUTINE RADF4 (IDO,L1,CC,CH,WA1,WA2,WA3)
+ DIMENSION CC(IDO,L1,4) ,CH(IDO,4,L1) ,
+ 1 WA1(1) ,WA2(1) ,WA3(1)
+ DATA HSQT2 /.7071067811865475/
+ DO 101 K=1,L1
+ TR1 = CC(1,K,2)+CC(1,K,4)
+ TR2 = CC(1,K,1)+CC(1,K,3)
+ CH(1,1,K) = TR1+TR2
+ CH(IDO,4,K) = TR2-TR1
+ CH(IDO,2,K) = CC(1,K,1)-CC(1,K,3)
+ CH(1,3,K) = CC(1,K,4)-CC(1,K,2)
+ 101 CONTINUE
+ IF (IDO-2) 107,105,102
+ 102 IDP2 = IDO+2
+!OCL NOVREC
+ DO 104 K=1,L1
+ DO 103 I=3,IDO,2
+ IC = IDP2-I
+ CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
+ CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
+ CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
+ CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
+ CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
+ CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
+ TR1 = CR2+CR4
+ TR4 = CR4-CR2
+ TI1 = CI2+CI4
+ TI4 = CI2-CI4
+ TI2 = CC(I,K,1)+CI3
+ TI3 = CC(I,K,1)-CI3
+ TR2 = CC(I-1,K,1)+CR3
+ TR3 = CC(I-1,K,1)-CR3
+ CH(I-1,1,K) = TR1+TR2
+ CH(IC-1,4,K) = TR2-TR1
+ CH(I,1,K) = TI1+TI2
+ CH(IC,4,K) = TI1-TI2
+ CH(I-1,3,K) = TI4+TR3
+ CH(IC-1,2,K) = TR3-TI4
+ CH(I,3,K) = TR4+TI3
+ CH(IC,2,K) = TR4-TI3
+ 103 CONTINUE
+ 104 CONTINUE
+ IF (MOD(IDO,2) .EQ. 1) RETURN
+ 105 CONTINUE
+ DO 106 K=1,L1
+ TI1 = -HSQT2*(CC(IDO,K,2)+CC(IDO,K,4))
+ TR1 = HSQT2*(CC(IDO,K,2)-CC(IDO,K,4))
+ CH(IDO,1,K) = TR1+CC(IDO,K,1)
+ CH(IDO,3,K) = CC(IDO,K,1)-TR1
+ CH(1,2,K) = TI1-CC(IDO,K,3)
+ CH(1,4,K) = TI1+CC(IDO,K,3)
+ 106 CONTINUE
+ 107 RETURN
+ END
+
+C> RADF5
+C>
+C> @param IDO
+C> @param L1
+C> @param CC
+C> @param CH
+C> @param WA1
+C> @param WA2
+C> @param WA3
+C> @param WA4
+C>
+C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO
+ SUBROUTINE RADF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4)
+ DIMENSION CC(IDO,L1,5) ,CH(IDO,5,L1) ,
+ 1 WA1(1) ,WA2(1) ,WA3(1) ,WA4(1)
+ DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154,
+ 1-.809016994374947,.587785252292473/
+ DO 101 K=1,L1
+ CR2 = CC(1,K,5)+CC(1,K,2)
+ CI5 = CC(1,K,5)-CC(1,K,2)
+ CR3 = CC(1,K,4)+CC(1,K,3)
+ CI4 = CC(1,K,4)-CC(1,K,3)
+ CH(1,1,K) = CC(1,K,1)+CR2+CR3
+ CH(IDO,2,K) = CC(1,K,1)+TR11*CR2+TR12*CR3
+ CH(1,3,K) = TI11*CI5+TI12*CI4
+ CH(IDO,4,K) = CC(1,K,1)+TR12*CR2+TR11*CR3
+ CH(1,5,K) = TI12*CI5-TI11*CI4
+ 101 CONTINUE
+ IF (IDO .EQ. 1) RETURN
+ IDP2 = IDO+2
+ DO 103 K=1,L1
+ DO 102 I=3,IDO,2
+ IC = IDP2-I
+ DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
+ DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
+ DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
+ DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
+ DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
+ DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
+ DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5)
+ DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5)
+ CR2 = DR2+DR5
+ CI5 = DR5-DR2
+ CR5 = DI2-DI5
+ CI2 = DI2+DI5
+ CR3 = DR3+DR4
+ CI4 = DR4-DR3
+ CR4 = DI3-DI4
+ CI3 = DI3+DI4
+ CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3
+ CH(I,1,K) = CC(I,K,1)+CI2+CI3
+ TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3
+ TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3
+ TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3
+ TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3
+ TR5 = TI11*CR5+TI12*CR4
+ TI5 = TI11*CI5+TI12*CI4
+ TR4 = TI12*CR5-TI11*CR4
+ TI4 = TI12*CI5-TI11*CI4
+ CH(I-1,3,K) = TR2+TR5
+ CH(IC-1,2,K) = TR2-TR5
+ CH(I,3,K) = TI2+TI5
+ CH(IC,2,K) = TI5-TI2
+ CH(I-1,5,K) = TR3+TR4
+ CH(IC-1,4,K) = TR3-TR4
+ CH(I,5,K) = TI3+TI4
+ CH(IC,4,K) = TI4-TI3
+ 102 CONTINUE
+ 103 CONTINUE
+ RETURN
+ END
+
+C> RADFG
+C>
+C> @param IDO
+C> @param IP
+C> @param L1
+C> @param IDL1
+C> @param CC
+C> @param C1
+C> @param C2
+C> @param CH
+C> @param CH2
+C> @param WA
+C>
+C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO
+ SUBROUTINE RADFG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)
+ DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) ,
+ 1 C1(IDO,L1,IP) ,C2(IDL1,IP),
+ 2 CH2(IDL1,IP) ,WA(1)
+ DATA TPI/6.28318530717959/
+ ARG = TPI/FLOAT(IP)
+ DCP = COS(ARG)
+ DSP = SIN(ARG)
+ IPPH = (IP+1)/2
+ IPP2 = IP+2
+ IDP2 = IDO+2
+ NBD = (IDO-1)/2
+ IF (IDO .EQ. 1) GO TO 119
+ DO 101 IK=1,IDL1
+ CH2(IK,1) = C2(IK,1)
+ 101 CONTINUE
+ DO 103 J=2,IP
+ DO 102 K=1,L1
+ CH(1,K,J) = C1(1,K,J)
+ 102 CONTINUE
+ 103 CONTINUE
+ IF (NBD .GT. L1) GO TO 107
+ IS = -IDO
+ DO 106 J=2,IP
+ IS = IS+IDO
+ IDIJ = IS
+ DO 105 I=3,IDO,2
+ IDIJ = IDIJ+2
+ DO 104 K=1,L1
+ CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J)
+ CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J)
+ 104 CONTINUE
+ 105 CONTINUE
+ 106 CONTINUE
+ GO TO 111
+ 107 IS = -IDO
+ DO 110 J=2,IP
+ IS = IS+IDO
+ DO 109 K=1,L1
+ IDIJ = IS
+ DO 108 I=3,IDO,2
+ IDIJ = IDIJ+2
+ CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J)
+ CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J)
+ 108 CONTINUE
+ 109 CONTINUE
+ 110 CONTINUE
+ 111 IF (NBD .LT. L1) GO TO 115
+ DO 114 J=2,IPPH
+ JC = IPP2-J
+ DO 113 K=1,L1
+ DO 112 I=3,IDO,2
+ C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC)
+ C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC)
+ C1(I,K,J) = CH(I,K,J)+CH(I,K,JC)
+ C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J)
+ 112 CONTINUE
+ 113 CONTINUE
+ 114 CONTINUE
+ GO TO 121
+ 115 DO 118 J=2,IPPH
+ JC = IPP2-J
+ DO 117 I=3,IDO,2
+ DO 116 K=1,L1
+ C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC)
+ C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC)
+ C1(I,K,J) = CH(I,K,J)+CH(I,K,JC)
+ C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J)
+ 116 CONTINUE
+ 117 CONTINUE
+ 118 CONTINUE
+ GO TO 121
+ 119 DO 120 IK=1,IDL1
+ C2(IK,1) = CH2(IK,1)
+ 120 CONTINUE
+ 121 DO 123 J=2,IPPH
+ JC = IPP2-J
+ DO 122 K=1,L1
+ C1(1,K,J) = CH(1,K,J)+CH(1,K,JC)
+ C1(1,K,JC) = CH(1,K,JC)-CH(1,K,J)
+ 122 CONTINUE
+ 123 CONTINUE
+C
+ AR1 = 1.
+ AI1 = 0.
+ DO 127 L=2,IPPH
+ LC = IPP2-L
+ AR1H = DCP*AR1-DSP*AI1
+ AI1 = DCP*AI1+DSP*AR1
+ AR1 = AR1H
+ DO 124 IK=1,IDL1
+ CH2(IK,L) = C2(IK,1)+AR1*C2(IK,2)
+ CH2(IK,LC) = AI1*C2(IK,IP)
+ 124 CONTINUE
+ DC2 = AR1
+ DS2 = AI1
+ AR2 = AR1
+ AI2 = AI1
+ DO 126 J=3,IPPH
+ JC = IPP2-J
+ AR2H = DC2*AR2-DS2*AI2
+ AI2 = DC2*AI2+DS2*AR2
+ AR2 = AR2H
+ DO 125 IK=1,IDL1
+ CH2(IK,L) = CH2(IK,L)+AR2*C2(IK,J)
+ CH2(IK,LC) = CH2(IK,LC)+AI2*C2(IK,JC)
+ 125 CONTINUE
+ 126 CONTINUE
+ 127 CONTINUE
+ DO 129 J=2,IPPH
+ DO 128 IK=1,IDL1
+ CH2(IK,1) = CH2(IK,1)+C2(IK,J)
+ 128 CONTINUE
+ 129 CONTINUE
+C
+ IF (IDO .LT. L1) GO TO 132
+ DO 131 K=1,L1
+ DO 130 I=1,IDO
+ CC(I,1,K) = CH(I,K,1)
+ 130 CONTINUE
+ 131 CONTINUE
+ GO TO 135
+ 132 DO 134 I=1,IDO
+ DO 133 K=1,L1
+ CC(I,1,K) = CH(I,K,1)
+ 133 CONTINUE
+ 134 CONTINUE
+ 135 DO 137 J=2,IPPH
+ JC = IPP2-J
+ J2 = J+J
+ DO 136 K=1,L1
+ CC(IDO,J2-2,K) = CH(1,K,J)
+ CC(1,J2-1,K) = CH(1,K,JC)
+ 136 CONTINUE
+ 137 CONTINUE
+ IF (IDO .EQ. 1) RETURN
+ IF (NBD .LT. L1) GO TO 141
+ DO 140 J=2,IPPH
+ JC = IPP2-J
+ J2 = J+J
+ DO 139 K=1,L1
+ DO 138 I=3,IDO,2
+ IC = IDP2-I
+ CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC)
+ CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC)
+ CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC)
+ CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J)
+ 138 CONTINUE
+ 139 CONTINUE
+ 140 CONTINUE
+ RETURN
+ 141 DO 144 J=2,IPPH
+ JC = IPP2-J
+ J2 = J+J
+ DO 143 I=3,IDO,2
+ IC = IDP2-I
+ DO 142 K=1,L1
+ CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC)
+ CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC)
+ CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC)
+ CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J)
+ 142 CONTINUE
+ 143 CONTINUE
+ 144 CONTINUE
+ RETURN
+ END
diff --git a/src/lapack_gen.F b/src/lapack_gen.F
new file mode 100644
index 00000000..36db1e46
--- /dev/null
+++ b/src/lapack_gen.F
@@ -0,0 +1,116 @@
+C> @file
+C> @brief Two Numerical Recipes routines for matrix inversion From Numerical Recipes.
+C>
+C> ### Program History Log
+C> Date | Programmer | Comments
+C> -----|------------|---------
+C> 2012-11-05 | E.Mirvis | separated this generic LU from the splat.F
+
+C> Solves a system of linear equations, follows call to ludcmp().
+C>
+C> @param A
+C> @param N
+C> @param NP
+C> @param INDX
+C> @param B
+ SUBROUTINE LUBKSB(A,N,NP,INDX,B)
+ REAL A(NP,NP),B(N)
+ INTEGER INDX(N)
+ II=0
+ DO 12 I=1,N
+ LL=INDX(I)
+ SUM=B(LL)
+ B(LL)=B(I)
+ IF (II.NE.0)THEN
+ DO 11 J=II,I-1
+ SUM=SUM-A(I,J)*B(J)
+ 11 CONTINUE
+ ELSE IF (SUM.NE.0.) THEN
+ II=I
+ ENDIF
+ B(I)=SUM
+ 12 CONTINUE
+ DO 14 I=N,1,-1
+ SUM=B(I)
+ IF(I.LT.N)THEN
+ DO 13 J=I+1,N
+ SUM=SUM-A(I,J)*B(J)
+ 13 CONTINUE
+ ENDIF
+ B(I)=SUM/A(I,I)
+ 14 CONTINUE
+ RETURN
+ END
+
+C> Replaces an NxN matrix a with the LU decomposition.
+C>
+C> @param A
+C> @param N
+C> @param NP
+C> @param INDX
+ SUBROUTINE LUDCMP(A,N,NP,INDX)
+C PARAMETER (NMAX=400,TINY=1.0E-20)
+ PARAMETER (TINY=1.0E-20)
+C==EM==^^^
+C
+ REAL A(NP,NP),VV(N),D
+C REAL A(NP,NP),VV(NMAX),D
+C==EM==^^^
+ INTEGER INDX(N)
+ D=1.
+ DO 12 I=1,N
+ AAMAX=0.
+ DO 11 J=1,N
+ IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
+ 11 CONTINUE
+ IF (AAMAX.EQ.0.) print *, 'SINGULAR MATRIX.'
+ VV(I)=1./AAMAX
+ 12 CONTINUE
+ DO 19 J=1,N
+ IF (J.GT.1) THEN
+ DO 14 I=1,J-1
+ SUM=A(I,J)
+ IF (I.GT.1)THEN
+ DO 13 K=1,I-1
+ SUM=SUM-A(I,K)*A(K,J)
+ 13 CONTINUE
+ A(I,J)=SUM
+ ENDIF
+ 14 CONTINUE
+ ENDIF
+ AAMAX=0.
+ DO 16 I=J,N
+ SUM=A(I,J)
+ IF (J.GT.1)THEN
+ DO 15 K=1,J-1
+ SUM=SUM-A(I,K)*A(K,J)
+ 15 CONTINUE
+ A(I,J)=SUM
+ ENDIF
+ DUM=VV(I)*ABS(SUM)
+ IF (DUM.GE.AAMAX) THEN
+ IMAX=I
+ AAMAX=DUM
+ ENDIF
+ 16 CONTINUE
+ IF (J.NE.IMAX)THEN
+ DO 17 K=1,N
+ DUM=A(IMAX,K)
+ A(IMAX,K)=A(J,K)
+ A(J,K)=DUM
+ 17 CONTINUE
+ D=-D
+ VV(IMAX)=VV(J)
+ ENDIF
+ INDX(J)=IMAX
+ IF(J.NE.N)THEN
+ IF(A(J,J).EQ.0.)A(J,J)=TINY
+ DUM=1./A(J,J)
+ DO 18 I=J+1,N
+ A(I,J)=A(I,J)*DUM
+ 18 CONTINUE
+ ENDIF
+ 19 CONTINUE
+ IF(A(N,N).EQ.0.)A(N,N)=TINY
+ RETURN
+ END
diff --git a/src/ncpus.F b/src/ncpus.F
new file mode 100644
index 00000000..2995c473
--- /dev/null
+++ b/src/ncpus.F
@@ -0,0 +1,40 @@
+C> @file
+C> Set number of cpus.
+C>
+C> ### Program History Log
+C> Date | Programmer | Comments
+C> -----|------------|---------
+C> 94-08-19 | Iredell | Initial.
+C> 98-11-09 | Vuong | Add doc>block and remove cray references.
+C> 1998-12-18 | Iredell | IBM SMP version.
+C> 2010-11-16 | Slovacek | Linux must have different call.
+C> 2012-11-01 | Mirvis | Multi-threading on LINUX-IBM/TIDE.
+C>
+C> @author Iredell @date 94-08-19
+
+C> Set number of CPUs - the number of processors over which
+C> to parallelize.
+C>
+C> @param[out] ncpus number of CPUs.
+C>
+C> @return Number of CPUs assigned.
+C>
+C> @author Iredell @date 94-08-19
+ FUNCTION NCPUS()
+ INTEGER NTHREADS, TID, OMP_GET_NUM_THREADS,OMP_GET_THREAD_NUM
+C Obtain thread number
+#ifdef OPENMP
+!$OMP PARALLEL PRIVATE(TID)
+ TID = OMP_GET_THREAD_NUM()
+! PRINT *, '...............thread # ', TID
+ if (TID. eq. 0) then
+ NCPUS=OMP_GET_NUM_THREADS()
+! PRINT *, 'totaly #------------------- of threads = ',NCPUS
+ endif
+!$OMP END PARALLEL
+#else
+ TID = 0
+ NCPUS = 1
+#endif
+ RETURN
+ END
diff --git a/src/spanaly.f b/src/spanaly.f
new file mode 100644
index 00000000..93f8a965
--- /dev/null
+++ b/src/spanaly.f
@@ -0,0 +1,76 @@
+C> @file
+C> @brief Analyze spectral from Fourier.
+C>
+C> ### Program History Log
+C> Date | Programmer | Comments
+C> -----|------------|---------
+C> 91-10-31 | Mark Iredell | Initial.
+C> 94-08-01 | Mark Iredell | Moved zonal wavenumber loop inside.
+C> 1998-12-15 | Iredell | Openmp directives inserted.
+C>
+C> @author Iredell @date 91-10-31
+
+C> Analyzes spectral coefficients from Fourier coefficients
+C> for a latitude pair (Northern and Southern hemispheres).
+C>
+C> Vector components are multiplied by cosine of latitude.
+C>
+C> @param I spectral domain shape (0 for triangular, 1 for rhomboidal)
+C> @param M spectral truncation
+C> @param IM even number of Fourier coefficients
+C> @param IX dimension of Fourier coefficients (IX>=IM+2)
+C> @param NC dimension of spectral coefficients (NC>=(M+1)*((I+1)*M+2))
+C> @param NCTOP dimension of spectral coefficients over top (NCTOP>=2*(M+1))
+C> @param KM number of fields
+C> @param WGT Gaussian weight
+C> @param CLAT cosine of latitude
+C> @param PLN Legendre polynomials
+C> @param PLNTOP Legendre polynomial over top
+C> @param MP identifiers (0 for scalar, 1 for vector)
+C> @param F Fourier coefficients combined
+C> @param SPC spectral coefficients
+C> @param SPCTOP spectral coefficients over top
+C>
+C> @author Iredell @date 91-10-31
+ SUBROUTINE SPANALY(I,M,IM,IX,NC,NCTOP,KM,WGT,CLAT,PLN,PLNTOP,MP,
+ & F,SPC,SPCTOP)
+ INTEGER MP(KM)
+ REAL PLN((M+1)*((I+1)*M+2)/2),PLNTOP(M+1)
+ REAL F(IX,2,KM)
+ REAL SPC(NC,KM),SPCTOP(NCTOP,KM)
+ REAL FW(2,2)
+
+C FOR EACH ZONAL WAVENUMBER, ANALYZE TERMS OVER TOTAL WAVENUMBER.
+C ANALYZE EVEN AND ODD POLYNOMIALS SEPARATELY.
+ LX=MIN(M,IM/2)
+!C$OMP PARALLEL DO PRIVATE(L,NT,KS,KP,FW)
+ DO K=1,KM
+ DO L=0,LX
+ NT=MOD(M+1+(I-1)*L,2)+1
+ KS=L*(2*M+(I-1)*(L-1))
+ KP=KS/2+1
+ IF(MP(K).EQ.0) THEN
+ FW(1,1)=WGT*(F(2*L+1,1,K)+F(2*L+1,2,K))
+ FW(2,1)=WGT*(F(2*L+2,1,K)+F(2*L+2,2,K))
+ FW(1,2)=WGT*(F(2*L+1,1,K)-F(2*L+1,2,K))
+ FW(2,2)=WGT*(F(2*L+2,1,K)-F(2*L+2,2,K))
+ ELSE
+ FW(1,1)=WGT*CLAT*(F(2*L+1,1,K)+F(2*L+1,2,K))
+ FW(2,1)=WGT*CLAT*(F(2*L+2,1,K)+F(2*L+2,2,K))
+ FW(1,2)=WGT*CLAT*(F(2*L+1,1,K)-F(2*L+1,2,K))
+ FW(2,2)=WGT*CLAT*(F(2*L+2,1,K)-F(2*L+2,2,K))
+ SPCTOP(2*L+1,K)=SPCTOP(2*L+1,K)+PLNTOP(L+1)*FW(1,NT)
+ SPCTOP(2*L+2,K)=SPCTOP(2*L+2,K)+PLNTOP(L+1)*FW(2,NT)
+ ENDIF
+ DO N=L,I*L+M,2
+ SPC(KS+2*N+1,K)=SPC(KS+2*N+1,K)+PLN(KP+N)*FW(1,1)
+ SPC(KS+2*N+2,K)=SPC(KS+2*N+2,K)+PLN(KP+N)*FW(2,1)
+ ENDDO
+ DO N=L+1,I*L+M,2
+ SPC(KS+2*N+1,K)=SPC(KS+2*N+1,K)+PLN(KP+N)*FW(1,2)
+ SPC(KS+2*N+2,K)=SPC(KS+2*N+2,K)+PLN(KP+N)*FW(2,2)
+ ENDDO
+ ENDDO
+ ENDDO
+ RETURN
+ END
diff --git a/src/spdz2uv.f b/src/spdz2uv.f
new file mode 100644
index 00000000..9bdc0efd
--- /dev/null
+++ b/src/spdz2uv.f
@@ -0,0 +1,82 @@
+C> @file
+C> @brief Compute winds from divergence and vorticity.
+C> @author Iredell @date 92-10-31
+
+C> Computes the wind components from divergence and vorticity
+C> in spectral space.
+C>
+C> Subprogram speps() should be called already.
+C>
+C> If L is the zonal wavenumber, N is the total wavenumber,
+C>
+C> EPS(L,N) = SQRT((N**2-L**2)/(4*N**2-1))
+C>
+C> and A is earth radius,
+C> then the zonal wind component U is computed as
+C>
+C> U(L,N)=-I*L/(N*(N+1))*A*D(L,N)
+C> +EPS(L,N+1)/(N+1)*A*Z(L,N+1)-EPS(L,N)/N*A*Z(L,N-1)
+C>
+C> and the meridional wind component V is computed as
+C>
+C> V(L,N)=-I*L/(N*(N+1))*A*Z(L,N)
+C> -EPS(L,N+1)/(N+1)*A*D(L,N+1)+EPS(L,N)/N*A*D(L,N-1)
+C>
+C> where D is divergence and Z is vorticity.
+C>
+C> U and V are weighted by the cosine of latitude.
+C>
+C> Cxtra terms are computed over top of the spectral domain.
+C>
+C> Advantage is taken of the fact that EPS(L,L)=0
+C> in order to vectorize over the entire spectral domain.
+C>
+C> @param I spectral domain shape (0 for triangular, 1 for rhomboidal)
+C> @param M spectral truncation
+C> @param ENN1 ((M+1)*((I+1)*M+2)/2) N*(N+1)/A**2
+C> @param ELONN1 ((M+1)*((I+1)*M+2)/2) L/(N*(N+1))*A
+C> @param EON ((M+1)*((I+1)*M+2)/2) EPSILON/N*A
+C> @param EONTOP (M+1) EPSILON/N*A OVER TOP
+C> @param D ((M+1)*((I+1)*M+2)) divergence
+C> @param Z ((M+1)*((I+1)*M+2)) vorticity
+C> @param U ((M+1)*((I+1)*M+2)) zonal wind (times coslat)
+C> @param V ((M+1)*((I+1)*M+2)) merid wind (times coslat)
+C> @param UTOP (2*(M+1)) zonal wind (times coslat) over top
+C> @param VTOP (2*(M+1)) merid wind (times coslat) over top
+C>
+C> @author Iredell @date 92-10-31
+ SUBROUTINE SPDZ2UV(I,M,ENN1,ELONN1,EON,EONTOP,D,Z,U,V,UTOP,VTOP)
+ REAL ENN1((M+1)*((I+1)*M+2)/2),ELONN1((M+1)*((I+1)*M+2)/2)
+ REAL EON((M+1)*((I+1)*M+2)/2),EONTOP(M+1)
+ REAL D((M+1)*((I+1)*M+2)),Z((M+1)*((I+1)*M+2))
+ REAL U((M+1)*((I+1)*M+2)),V((M+1)*((I+1)*M+2))
+ REAL UTOP(2*(M+1)),VTOP(2*(M+1))
+
+C COMPUTE WINDS IN THE SPECTRAL DOMAIN
+ K=1
+ U(2*K-1)=EON(K+1)*Z(2*K+1)
+ U(2*K)=EON(K+1)*Z(2*K+2)
+ V(2*K-1)=-EON(K+1)*D(2*K+1)
+ V(2*K)=-EON(K+1)*D(2*K+2)
+ DO K=2,(M+1)*((I+1)*M+2)/2-1
+ U(2*K-1)=ELONN1(K)*D(2*K)+EON(K+1)*Z(2*K+1)-EON(K)*Z(2*K-3)
+ U(2*K)=-ELONN1(K)*D(2*K-1)+EON(K+1)*Z(2*K+2)-EON(K)*Z(2*K-2)
+ V(2*K-1)=ELONN1(K)*Z(2*K)-EON(K+1)*D(2*K+1)+EON(K)*D(2*K-3)
+ V(2*K)=-ELONN1(K)*Z(2*K-1)-EON(K+1)*D(2*K+2)+EON(K)*D(2*K-2)
+ ENDDO
+ K=(M+1)*((I+1)*M+2)/2
+ U(2*K-1)=ELONN1(K)*D(2*K)-EON(K)*Z(2*K-3)
+ U(2*K)=-ELONN1(K)*D(2*K-1)-EON(K)*Z(2*K-2)
+ V(2*K-1)=ELONN1(K)*Z(2*K)+EON(K)*D(2*K-3)
+ V(2*K)=-ELONN1(K)*Z(2*K-1)+EON(K)*D(2*K-2)
+
+C COMPUTE WINDS OVER TOP OF THE SPECTRAL DOMAIN
+ DO L=0,M
+ K=L*(2*M+(I-1)*(L-1))/2+I*L+M+1
+ UTOP(2*L+1)=-EONTOP(L+1)*Z(2*K-1)
+ UTOP(2*L+2)=-EONTOP(L+1)*Z(2*K)
+ VTOP(2*L+1)=EONTOP(L+1)*D(2*K-1)
+ VTOP(2*L+2)=EONTOP(L+1)*D(2*K)
+ ENDDO
+ RETURN
+ END
diff --git a/src/speps.f b/src/speps.f
new file mode 100644
index 00000000..691c7dc6
--- /dev/null
+++ b/src/speps.f
@@ -0,0 +1,53 @@
+C> @file
+C> @brief Compute utility spectral fields.
+C> @author Iredell @date 92-10-31
+
+C> Computes constant fields indexed in the spectral domain
+C> in "IBM ORDER" (Zonal wavenumber is the slower index).
+C>
+C> If L is the zonal wavenumber and N is the total wavenumber
+C> and A is the earth radius, then the fields returned are:
+C> - (1) normalizing factor EPSILON=SQRT((N**2-L**2)/(4*N**2-1))
+C> - (2) Laplacian factor N*(N+1)/A**2
+C> - (3) zonal derivative/Laplacian factor L/(N*(N+1))*A
+C> - (4) Meridional derivative/Laplacian factor EPSILON/N*A
+C>
+C> @param I spectral domain shape (0 for triangular, 1 for rhomboidal)
+C> @param M spectral truncation
+C> @param EPS ((M+1)*((I+1)*M+2)/2) SQRT((N**2-L**2)/(4*N**2-1))
+C> @param EPSTOP (M+1) SQRT((N**2-L**2)/(4*N**2-1)) OVER TOP
+C> @param ENN1 ((M+1)*((I+1)*M+2)/2) N*(N+1)/A**2
+C> @param ELONN1 ((M+1)*((I+1)*M+2)/2) L/(N*(N+1))*A
+C> @param EON ((M+1)*((I+1)*M+2)/2) EPSILON/N*A
+C> @param EONTOP (M+1) EPSILON/N*A OVER TOP
+C>
+C> @author Iredell @date 92-10-31
+ SUBROUTINE SPEPS(I,M,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP)
+ REAL EPS((M+1)*((I+1)*M+2)/2),EPSTOP(M+1)
+ REAL ENN1((M+1)*((I+1)*M+2)/2),ELONN1((M+1)*((I+1)*M+2)/2)
+ REAL EON((M+1)*((I+1)*M+2)/2),EONTOP(M+1)
+ PARAMETER(RERTH=6.3712E6,RA2=1./RERTH**2)
+
+ DO L=0,M
+ K=L*(2*M+(I-1)*(L-1))/2+L+1
+ EPS(K)=0.
+ ENN1(K)=RA2*L*(L+1)
+ ELONN1(K)=RERTH/(L+1)
+ EON(K)=0.
+ ENDDO
+ DO L=0,M
+ DO N=L+1,I*L+M
+ K=L*(2*M+(I-1)*(L-1))/2+N+1
+ EPS(K)=SQRT(FLOAT(N**2-L**2)/FLOAT(4*N**2-1))
+ ENN1(K)=RA2*N*(N+1)
+ ELONN1(K)=RERTH*L/(N*(N+1))
+ EON(K)=RERTH/N*EPS(K)
+ ENDDO
+ ENDDO
+ DO L=0,M
+ N=I*L+M+1
+ EPSTOP(L+1)=SQRT(FLOAT(N**2-L**2)/FLOAT(4*N**2-1))
+ EONTOP(L+1)=RERTH/N*EPSTOP(L+1)
+ ENDDO
+ RETURN
+ END
diff --git a/src/spfft.f b/src/spfft.f
new file mode 100644
index 00000000..672bb025
--- /dev/null
+++ b/src/spfft.f
@@ -0,0 +1,75 @@
+C> @file
+C> @brief Perform multiple fast fourier transforms.
+C> @author Iredell @date 96-02-20
+
+C> This subprogram performs multiple fast fourier transforms
+C> between complex amplitudes in fourier space and real values
+C> in cyclic physical space.
+C>
+C> Subprogram spfft must be invoked first with idir=0
+C> to initialize trigonemetric data. Use subprogram spfft1
+C> to perform an fft without previous initialization.
+C> This version invokes the ibm essl fft.
+C>
+C> The restrictions on imax are that it must be a multiple
+C> of 1 to 25 factors of two, up to 2 factors of three,
+C> and up to 1 factor of five, seven and eleven.
+C>
+C> If IDIR=0, then W and G need not contain any valid data.
+C> the other parameters must be supplied and cannot change
+C> in succeeding calls until the next time it is called with IDIR=0.
+C>
+C> This subprogram is not thread-safe when IDIR=0. On the other hand,
+C> when IDIR is not zero, it can be called from a threaded region.
+C>
+C> @param IMAX number of values in the cyclic physical space
+C> (see limitations on imax in remarks below.)
+C> @param INCW first dimension of the complex amplitude array
+C> (INCW >= IMAX/2+1)
+C> @param INCG first dimension of the real value array
+C> (INCG >= IMAX)
+C> @param KMAX number of transforms to perform
+C> @param[out] W complex amplitudes if IDIR>0
+C> @param[out] G real values if IDIR<0
+C> @param IDIR direction flag
+C> - IDIR=0 to initialize internal trigonometric data
+C> - IDIR>0 TO transform from Fourier to physical space
+C> - IDIR<0 TO transform from physical to fourier space
+C>
+C> @author Iredell @date 96-02-20
+ SUBROUTINE SPFFT(IMAX,INCW,INCG,KMAX,W,G,IDIR)
+
+ IMPLICIT NONE
+ INTEGER,INTENT(IN):: IMAX,INCW,INCG,KMAX,IDIR
+ COMPLEX,INTENT(INOUT):: W(INCW,KMAX)
+ REAL,INTENT(INOUT):: G(INCG,KMAX)
+ INTEGER,SAVE:: NAUX1=0
+ REAL,SAVE,ALLOCATABLE:: AUX1CR(:),AUX1RC(:)
+ INTEGER:: NAUX2
+ REAL:: AUX2(20000+INT(0.57*IMAX))
+
+ NAUX2=20000+INT(0.57*IMAX)
+
+C INITIALIZATION.
+C ALLOCATE AND FILL AUXILIARY ARRAYS WITH TRIGONOMETRIC DATA
+ SELECT CASE(IDIR)
+ CASE(0)
+ IF(NAUX1.GT.0) DEALLOCATE(AUX1CR,AUX1RC)
+ NAUX1=25000+INT(0.82*IMAX)
+ ALLOCATE(AUX1CR(NAUX1),AUX1RC(NAUX1))
+ CALL SCRFT(1,W,INCW,G,INCG,IMAX,KMAX,-1,1.,
+ & AUX1CR,NAUX1,AUX2,NAUX2,0.,0)
+ CALL SRCFT(1,G,INCG,W,INCW,IMAX,KMAX,+1,1./IMAX,
+ & AUX1RC,NAUX1,AUX2,NAUX2,0.,0)
+
+C FOURIER TO PHYSICAL TRANSFORM.
+ CASE(1:)
+ CALL SCRFT(0,W,INCW,G,INCG,IMAX,KMAX,-1,1.,
+ & AUX1CR,NAUX1,AUX2,NAUX2,0.,0)
+
+C PHYSICAL TO FOURIER TRANSFORM.
+ CASE(:-1)
+ CALL SRCFT(0,G,INCG,W,INCW,IMAX,KMAX,+1,1./IMAX,
+ & AUX1RC,NAUX1,AUX2,NAUX2,0.,0)
+ END SELECT
+ END SUBROUTINE
diff --git a/src/spfft1.f b/src/spfft1.f
new file mode 100644
index 00000000..4800356a
--- /dev/null
+++ b/src/spfft1.f
@@ -0,0 +1,59 @@
+C> @file
+C> @brief Perform multiple fast Fourier transforms.
+C> @author Iredell @date 96-02-20
+
+C> This subprogram performs multiple fast Fourier transforms
+C> between complex amplitudes in Fourier space and real values
+C> in cyclic physical space.
+C>
+C> Subprogram spfft1() initializes trigonometric data each call.
+C> Use subprogram spfft() to save time and initialize once.
+C> This version invokes the IBM ESSL FFT.
+C>
+C> @note The restrictions on IMAX are that it must be a multiple of 1
+C> to 25 factors of two, up to 2 factors of three, and up to 1 factor of
+C> five, seven and eleven.
+C>
+C> @note This subprogram is thread-safe.
+C>
+C> @param IMAX number of values in the cyclic physical space
+C> (see limitations on imax in remarks below.)
+C> @param INCW first dimension of the complex amplitude array
+C> (INCW >= IMAX/2+1)
+C> @param INCG first dimension of the real value array (INCG >= IMAX)
+C> @param KMAX number of transforms to perform
+C> @param[out] W complex amplitudes if IDIR>0
+C> @param[out] G values if IDIR<0
+C> @param IDIR direction flag
+C> - IDIR>0 to transform from Fourier to physical space
+C> - IDIR<0 to transform from physical to Fourier space
+C>
+C> @author Iredell @date 96-02-20
+ SUBROUTINE SPFFT1(IMAX,INCW,INCG,KMAX,W,G,IDIR)
+ IMPLICIT NONE
+ INTEGER,INTENT(IN):: IMAX,INCW,INCG,KMAX,IDIR
+ COMPLEX,INTENT(INOUT):: W(INCW,KMAX)
+ REAL,INTENT(INOUT):: G(INCG,KMAX)
+ REAL:: AUX1(25000+INT(0.82*IMAX))
+ REAL:: AUX2(20000+INT(0.57*IMAX))
+ INTEGER:: NAUX1,NAUX2
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ NAUX1=25000+INT(0.82*IMAX)
+ NAUX2=20000+INT(0.57*IMAX)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C FOURIER TO PHYSICAL TRANSFORM.
+ SELECT CASE(IDIR)
+ CASE(1:)
+ CALL SCRFT(1,W,INCW,G,INCG,IMAX,KMAX,-1,1.,
+ & AUX1,NAUX1,AUX2,NAUX2,0.,0)
+ CALL SCRFT(0,W,INCW,G,INCG,IMAX,KMAX,-1,1.,
+ & AUX1,NAUX1,AUX2,NAUX2,0.,0)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C PHYSICAL TO FOURIER TRANSFORM.
+ CASE(:-1)
+ CALL SRCFT(1,G,INCG,W,INCW,IMAX,KMAX,+1,1./IMAX,
+ & AUX1,NAUX1,AUX2,NAUX2,0.,0)
+ CALL SRCFT(0,G,INCG,W,INCW,IMAX,KMAX,+1,1./IMAX,
+ & AUX1,NAUX1,AUX2,NAUX2,0.,0)
+ END SELECT
+ END SUBROUTINE
diff --git a/src/spffte.f b/src/spffte.f
new file mode 100644
index 00000000..d7beb288
--- /dev/null
+++ b/src/spffte.f
@@ -0,0 +1,133 @@
+C> @file
+C> @brief Perform multiple fast Fourier transforms.
+C>
+C> ### Program History Log
+C> Date | Programmer | Comments
+C> -----|------------|---------
+C> 1998-12-18 | Iredell | Initial.
+C> 2012-11-12 | Mirvis | fixing hard-wired types problem on Intel/Linux.
+C>
+C> @author Iredell @date 96-02-20
+
+C> This subprogram performs multiple fast Fourier transforms
+C> between complex amplitudes in Fourier space and real values
+C> in cyclic physical space.
+C>
+C> This subprogram must be invoked first with IDIR=0
+C> to initialize trigonemetric data. Use subprogram spfft1()
+C> to perform an FFT without previous initialization.
+C>
+C> This version invokes the IBM ESSL FFT.
+C>
+C> @note The restrictions on IMAX are that it must be a multiple
+C> of 1 to 25 factors of two, up to 2 factors of three,
+C> and up to 1 factor of five, seven and eleven.
+C>
+C> If IDIR=0, then W and G need not contain any valid data.
+C> The other parameters must be supplied and cannot change
+C> in succeeding calls until the next time it is called with IDIR=0.
+C>
+C> This subprogram is thread-safe.
+C>
+C> @param IMAX number of values in the cyclic physical space
+C> (see limitations on imax in remarks below.)
+C> @param INCW first dimension of the complex amplitude array
+C> (INCW >= IMAX/2+1)
+C> @param INCG first dimension of the real value array
+C> (INCG >= IMAX)
+C> @param KMAX number of transforms to perform
+C> @param[out] W complex amplitudes if IDIR>0
+C> @param[out] G real values if IDIR<0
+C> @param IDIR direction flag
+C> - IDIR=0 to initialize trigonometric data
+C> - IDIR>0 to transform from Fourier to physical space
+C> - IDIR<0 to transform from physical to Fourier space
+C> @param[out] AFFT auxiliary array if IDIR<>0
+C>
+C> @author Iredell @date 96-02-20
+ SUBROUTINE SPFFTE(IMAX,INCW,INCG,KMAX,W,G,IDIR,AFFT)
+ IMPLICIT NONE
+ INTEGER,INTENT(IN):: IMAX,INCW,INCG,KMAX,IDIR
+ REAL,INTENT(INOUT):: W(2*INCW,KMAX)
+ REAL,INTENT(INOUT):: G(INCG,KMAX)
+ REAL(8),INTENT(INOUT):: AFFT(50000+4*IMAX)
+ INTEGER:: INIT,INC2X,INC2Y,N,M,ISIGN,NAUX1,NAUX2,NAUX3
+C ==EM== ^(4)
+ REAL:: SCALE
+ REAL(8):: AUX2(20000+2*IMAX),AUX3
+ INTEGER:: IACR,IARC
+
+ NAUX1=25000+2*IMAX
+ NAUX2=20000+2*IMAX
+ NAUX3=1
+ IACR=1
+ IARC=1+NAUX1
+
+C INITIALIZATION.
+C FILL AUXILIARY ARRAYS WITH TRIGONOMETRIC DATA
+ SELECT CASE(IDIR)
+ CASE(0)
+ INIT=1
+ INC2X=INCW
+ INC2Y=INCG
+ N=IMAX
+ M=KMAX
+ ISIGN=-1
+ SCALE=1.
+ IF(DIGITS(1.).LT.DIGITS(1._8)) THEN
+ CALL SCRFT(INIT,W,INC2X,G,INC2Y,N,M,ISIGN,SCALE,
+ & AFFT(IACR),NAUX1,AUX2,NAUX2,AUX3,NAUX3)
+ ELSE
+ CALL DCRFT(INIT,W,INC2X,G,INC2Y,N,M,ISIGN,SCALE,
+ & AFFT(IACR),NAUX1,AUX2,NAUX2)
+ ENDIF
+ INIT=1
+ INC2X=INCG
+ INC2Y=INCW
+ N=IMAX
+ M=KMAX
+ ISIGN=+1
+ SCALE=1./IMAX
+ IF(DIGITS(1.).LT.DIGITS(1._8)) THEN
+ CALL SRCFT(INIT,G,INC2X,W,INC2Y,N,M,ISIGN,SCALE,
+ & AFFT(IARC),NAUX1,AUX2,NAUX2,AUX3,NAUX3)
+ ELSE
+ CALL DRCFT(INIT,G,INC2X,W,INC2Y,N,M,ISIGN,SCALE,
+ & AFFT(IARC),NAUX1,AUX2,NAUX2)
+ ENDIF
+
+C FOURIER TO PHYSICAL TRANSFORM.
+ CASE(1:)
+ INIT=0
+ INC2X=INCW
+ INC2Y=INCG
+ N=IMAX
+ M=KMAX
+ ISIGN=-1
+ SCALE=1.
+ IF(DIGITS(1.).LT.DIGITS(1._8)) THEN
+ CALL SCRFT(INIT,W,INC2X,G,INC2Y,N,M,ISIGN,SCALE,
+ & AFFT(IACR),NAUX1,AUX2,NAUX2,AUX3,NAUX3)
+ ELSE
+ CALL DCRFT(INIT,W,INC2X,G,INC2Y,N,M,ISIGN,SCALE,
+ & AFFT(IACR),NAUX1,AUX2,NAUX2)
+ ENDIF
+
+C PHYSICAL TO FOURIER TRANSFORM.
+ CASE(:-1)
+ INIT=0
+ INC2X=INCG
+ INC2Y=INCW
+ N=IMAX
+ M=KMAX
+ ISIGN=+1
+ SCALE=1./IMAX
+ IF(DIGITS(1.).LT.DIGITS(1._8)) THEN
+ CALL SRCFT(INIT,G,INC2X,W,INC2Y,N,M,ISIGN,SCALE,
+ & AFFT(IARC),NAUX1,AUX2,NAUX2,AUX3,NAUX3)
+ ELSE
+ CALL DRCFT(INIT,G,INC2X,W,INC2Y,N,M,ISIGN,SCALE,
+ & AFFT(IARC),NAUX1,AUX2,NAUX2)
+ ENDIF
+ END SELECT
+ END SUBROUTINE
diff --git a/src/spfftpt.f b/src/spfftpt.f
new file mode 100644
index 00000000..72a53de8
--- /dev/null
+++ b/src/spfftpt.f
@@ -0,0 +1,48 @@
+C> @file
+C> @brief Compute fourier transform to gridpoints.
+C> @author Iredell @date 96-02-20
+
+C> This subprogram computes a slow Fourier transform
+C> from Fourier space to a set of gridpoints.
+C>
+C> @note This subprogram is thread-safe.
+C>
+C> @param M Fourier wavenumber truncation
+C> @param N number of gridpoints
+C> @param INCW first dimension of the complex amplitude array
+C> (INCW >= M+1)
+C> @param INCG first dimension of the gridpoint array
+C> (INCG >= N)
+C> @param KMAX number of Fourier fields
+C> @param RLON grid longitudes in degrees
+C> @param W Fourier amplitudes
+C> @param G gridpoint values
+C>
+C> @author Iredell @date 96-02-20
+ SUBROUTINE SPFFTPT(M,N,INCW,INCG,KMAX,RLON,W,G)
+
+ IMPLICIT NONE
+ INTEGER,INTENT(IN):: M,N,INCW,INCG,KMAX
+ REAL,INTENT(IN):: RLON(N)
+ REAL,INTENT(IN):: W(2*INCW,KMAX)
+ REAL,INTENT(OUT):: G(INCG,KMAX)
+ INTEGER I,K,L
+ REAL RADLON,SLON(M),CLON(M)
+ REAL,PARAMETER:: PI=3.14159265358979
+
+ DO I=1,N
+ RADLON=PI/180*RLON(I)
+ DO L=1,M
+ SLON(L)=SIN(L*RADLON)
+ CLON(L)=COS(L*RADLON)
+ ENDDO
+ DO K=1,KMAX
+ G(I,K)=W(1,K)
+ ENDDO
+ DO L=1,M
+ DO K=1,KMAX
+ G(I,K)=G(I,K)+2.*(W(2*L+1,K)*CLON(L)-W(2*L+2,K)*SLON(L))
+ ENDDO
+ ENDDO
+ ENDDO
+ END SUBROUTINE
diff --git a/src/spgradq.f b/src/spgradq.f
new file mode 100644
index 00000000..9fa03873
--- /dev/null
+++ b/src/spgradq.f
@@ -0,0 +1,66 @@
+C> @file
+C> @brief Compute gradient in spectral space.
+C> @author Iredell @date 92-10-31
+
+C> Computes the horizontal vector gradient of a scalar field
+C> in spectral space.
+C>
+C> Subprogram speps() should be called already.
+C>
+C> If l is the zonal wavenumber, n is the total wavenumber,
+C> eps(l,n)=sqrt((n**2-l**2)/(4*n**2-1)) and a is earth radius,
+C> then the zonal gradient of q(l,n) is simply i*l/a*q(l,n)
+C> while the meridional gradient of q(l,n) is computed as
+C> eps(l,n+1)*(n+2)/a*q(l,n+1)-eps(l,n+1)*(n-1)/a*q(l,n-1).
+C>
+C> Extra terms are computed over top of the spectral domain.
+C>
+C> Advantage is taken of the fact that eps(l,l)=0
+C> in order to vectorize over the entire spectral domain.
+C>
+C> @param I spectral domain shape (0 for triangular, 1 for rhomboidal)
+C> @param M spectral truncation
+C> @param ENN1
+C> @param ELONN1
+C> @param EON EPSILON/N*A
+C> @param EONTOP EPSILON/N*A over top
+C> @param Q scalar field
+C> @param QDX zonal gradient (times coslat)
+C> @param QDY merid gradient (times coslat)
+C> @param QDYTOP merid gradient (times coslat) over top
+C>
+C> @author IREDELL @date 92-10-31
+ SUBROUTINE SPGRADQ(I,M,ENN1,ELONN1,EON,EONTOP,Q,QDX,QDY,QDYTOP)
+
+ REAL ENN1((M+1)*((I+1)*M+2)/2),ELONN1((M+1)*((I+1)*M+2)/2)
+ REAL EON((M+1)*((I+1)*M+2)/2),EONTOP(M+1)
+ REAL Q((M+1)*((I+1)*M+2))
+ REAL QDX((M+1)*((I+1)*M+2)),QDY((M+1)*((I+1)*M+2))
+ REAL QDYTOP(2*(M+1))
+
+C TAKE ZONAL AND MERIDIONAL GRADIENTS
+ K=1
+ QDX(2*K-1)=0.
+ QDX(2*K)=0.
+ QDY(2*K-1)=EON(K+1)*ENN1(K+1)*Q(2*K+1)
+ QDY(2*K)=EON(K+1)*ENN1(K+1)*Q(2*K+2)
+ DO K=2,(M+1)*((I+1)*M+2)/2-1
+ QDX(2*K-1)=-ELONN1(K)*ENN1(K)*Q(2*K)
+ QDX(2*K)=ELONN1(K)*ENN1(K)*Q(2*K-1)
+ QDY(2*K-1)=EON(K+1)*ENN1(K+1)*Q(2*K+1)-EON(K)*ENN1(K-1)*Q(2*K-3)
+ QDY(2*K)=EON(K+1)*ENN1(K+1)*Q(2*K+2)-EON(K)*ENN1(K-1)*Q(2*K-2)
+ ENDDO
+ K=(M+1)*((I+1)*M+2)/2
+ QDX(2*K-1)=-ELONN1(K)*ENN1(K)*Q(2*K)
+ QDX(2*K)=ELONN1(K)*ENN1(K)*Q(2*K-1)
+ QDY(2*K-1)=-EON(K)*ENN1(K-1)*Q(2*K-3)
+ QDY(2*K)=-EON(K)*ENN1(K-1)*Q(2*K-2)
+
+C TAKE MERIDIONAL GRADIENT OVER TOP
+ DO L=0,M
+ K=L*(2*M+(I-1)*(L-1))/2+I*L+M+1
+ QDYTOP(2*L+1)=-EONTOP(L+1)*ENN1(K)*Q(2*K-1)
+ QDYTOP(2*L+2)=-EONTOP(L+1)*ENN1(K)*Q(2*K)
+ ENDDO
+ RETURN
+ END
diff --git a/src/spgradx.f b/src/spgradx.f
new file mode 100644
index 00000000..e3e2e4f1
--- /dev/null
+++ b/src/spgradx.f
@@ -0,0 +1,72 @@
+C> @file
+C> @brief Compute x-gradient in Fourier space
+C> @author IREDELL @date 96-02-20
+
+C> This subprogram computes the x-gradient of fields
+C> in complex Fourier space.
+C>
+C> The x-gradient of a vector field W is
+C> WX=CONJG(W)*L/RERTH
+C> where L is the wavenumber and RERTH is the Earth radius,
+C> so that the result is the x-gradient of the pseudo-vector.
+C>
+C> The x-gradient of a scalar field W is
+C> WX=CONJG(W)*L/(RERTH*CLAT)
+C> where CLAT is the cosine of latitude.
+C>
+C> At the pole this is undefined, so the way to get
+C> the x-gradient at the pole is by passing both
+C> the weighted wavenumber 0 and the unweighted wavenumber 1
+C> amplitudes at the pole and setting MP=10.
+C> In this case, the wavenumber 1 amplitudes are used
+C> to compute the x-gradient and then zeroed out.
+C>
+C> @note This subprogram is thread-safe.
+C>
+C> @param M Fourier wavenumber truncation
+C> @param INCW first dimension of the complex amplitude array
+C> (INCW >= M+1)
+C> @param KMAX number of Fourier fields
+C> @param MP identifiers
+C> (0 or 10 for scalar, 1 for vector)
+C> @param CLAT cosine of latitude
+C> @param[out] W Fourier amplitudes corrected when MP=10 and CLAT=0
+C> @param[out] WX complex amplitudes of x-gradients
+C>
+C> @author IREDELL @date 96-02-20
+ SUBROUTINE SPGRADX(M,INCW,KMAX,MP,CLAT,W,WX)
+
+ IMPLICIT NONE
+ INTEGER,INTENT(IN):: M,INCW,KMAX,MP(KMAX)
+ REAL,INTENT(IN):: CLAT
+ REAL,INTENT(INOUT):: W(2*INCW,KMAX)
+ REAL,INTENT(OUT):: WX(2*INCW,KMAX)
+ INTEGER K,L
+ REAL,PARAMETER:: RERTH=6.3712E6
+
+ DO K=1,KMAX
+ IF(MP(K).EQ.1) THEN
+ DO L=0,M
+ WX(2*L+1,K)=-W(2*L+2,K)*(L/RERTH)
+ WX(2*L+2,K)=+W(2*L+1,K)*(L/RERTH)
+ ENDDO
+ ELSEIF(CLAT.EQ.0.) THEN
+ DO L=0,M
+ WX(2*L+1,K)=0
+ WX(2*L+2,K)=0
+ ENDDO
+ IF(MP(K).EQ.10.AND.M.GE.2) THEN
+ WX(3,K)=-W(4,K)/RERTH
+ WX(4,K)=+W(3,K)/RERTH
+ W(3,K)=0
+ W(4,K)=0
+ ENDIF
+ ELSE
+ DO L=0,M
+ WX(2*L+1,K)=-W(2*L+2,K)*(L/(RERTH*CLAT))
+ WX(2*L+2,K)=+W(2*L+1,K)*(L/(RERTH*CLAT))
+ ENDDO
+ ENDIF
+ ENDDO
+
+ END SUBROUTINE
diff --git a/src/spgrady.f b/src/spgrady.f
new file mode 100644
index 00000000..922ca501
--- /dev/null
+++ b/src/spgrady.f
@@ -0,0 +1,59 @@
+C> @file
+C> @brief Compute y-gradient in spectral space.
+C> @author IREDELL @date 92-10-31
+
+C> Computes the horizontal vector y-gradient of a scalar field
+c> in spectral space.
+C>
+C> Subprogram speps should be called already.
+C>
+C> If L is the zonal wavenumber, N is the total wavenumber,
+C> EPS(L,N)=SQRT((N**2-L**2)/(4*N**2-1)) and A is Earth radius,
+C> then the meridional gradient of Q(L,N) is computed as
+C> EPS(L,N+1)*(N+2)/A*Q(L,N+1)-EPS(L,N+1)*(N-1)/A*Q(L,N-1).
+C>
+C> Extra terms are computed over top of the spectral domain.
+C>
+C> Advantage is taken of the fact that EPS(L,L)=0
+C> in order to vectorize over the entire spectral domain.
+C>
+C> @param I spectral domain shape
+c> (0 for triangular, 1 for rhomboidal)
+C> @param M spectral truncation
+C> @param ENN1 N*(N+1)/A**2
+C> @param EON EPSILON/N*A
+C> @param EONTOP EPSILON/N*A over top
+C> @param Q scalar field
+C> @param QDY merid gradient (times coslat)
+C> @param QDYTOP merid gradient (times coslat) over top
+C>
+C> @author IREDELL @date 92-10-31
+ SUBROUTINE SPGRADY(I,M,ENN1,EON,EONTOP,Q,QDY,QDYTOP)
+
+ REAL ENN1((M+1)*((I+1)*M+2)/2)
+ REAL EON((M+1)*((I+1)*M+2)/2),EONTOP(M+1)
+ REAL Q((M+1)*((I+1)*M+2))
+ REAL QDY((M+1)*((I+1)*M+2))
+ REAL QDYTOP(2*(M+1))
+
+C TAKE MERIDIONAL GRADIENT
+ K=1
+ QDY(2*K-1)=EON(K+1)*ENN1(K+1)*Q(2*K+1)
+ QDY(2*K)=EON(K+1)*ENN1(K+1)*Q(2*K+2)
+ DO K=2,(M+1)*((I+1)*M+2)/2-1
+ QDY(2*K-1)=EON(K+1)*ENN1(K+1)*Q(2*K+1)-EON(K)*ENN1(K-1)*Q(2*K-3)
+ QDY(2*K)=EON(K+1)*ENN1(K+1)*Q(2*K+2)-EON(K)*ENN1(K-1)*Q(2*K-2)
+ ENDDO
+ K=(M+1)*((I+1)*M+2)/2
+ QDY(2*K-1)=-EON(K)*ENN1(K-1)*Q(2*K-3)
+ QDY(2*K)=-EON(K)*ENN1(K-1)*Q(2*K-2)
+
+C TAKE MERIDIONAL GRADIENT OVER TOP
+ DO L=0,M
+ K=L*(2*M+(I-1)*(L-1))/2+I*L+M+1
+ QDYTOP(2*L+1)=-EONTOP(L+1)*ENN1(K)*Q(2*K-1)
+ QDYTOP(2*L+2)=-EONTOP(L+1)*ENN1(K)*Q(2*K)
+ ENDDO
+
+ RETURN
+ END
diff --git a/src/splaplac.f b/src/splaplac.f
new file mode 100644
index 00000000..f0ce9274
--- /dev/null
+++ b/src/splaplac.f
@@ -0,0 +1,49 @@
+C> @file
+C> @brief Compute laplacian in spectral space.
+C> @author Iredell @date 92-10-31
+
+C> Computes the laplacian or the inverse laplacian
+C> of a scalar field in spectral space.
+C>
+C> Subprogram speps() should be called already.
+C>
+C> The Laplacian of Q(L,N) is simply -N*(N+1)/A**2*Q(L,N)
+C>
+C> @param I spectral domain shape
+C> (0 for triangular, 1 for rhomboidal)
+C> @param M spectral truncation
+C> @param ENN1 N*(N+1)/A**2
+C> @param[out] Q if IDIR > 0, scalar field
+C> (Q(0,0) is not computed)
+C> @param[out] QD2 if IDIR < 0, Laplacian
+C> @param IDIR flag
+C> - IDIR > 0 to take Laplacian
+C> - IDIR < 0 to take inverse Laplacian
+C>
+C> @author Iredell @date 92-10-31
+ SUBROUTINE SPLAPLAC(I,M,ENN1,Q,QD2,IDIR)
+
+ REAL ENN1((M+1)*((I+1)*M+2)/2)
+ REAL Q((M+1)*((I+1)*M+2))
+ REAL QD2((M+1)*((I+1)*M+2))
+
+C TAKE LAPLACIAN
+ IF(IDIR.GT.0) THEN
+ K=1
+ QD2(2*K-1)=0.
+ QD2(2*K)=0.
+ DO K=2,(M+1)*((I+1)*M+2)/2
+ QD2(2*K-1)=Q(2*K-1)*(-ENN1(K))
+ QD2(2*K)=Q(2*K)*(-ENN1(K))
+ ENDDO
+
+C TAKE INVERSE LAPLACIAN
+ ELSE
+ DO K=2,(M+1)*((I+1)*M+2)/2
+ Q(2*K-1)=QD2(2*K-1)/(-ENN1(K))
+ Q(2*K)=QD2(2*K)/(-ENN1(K))
+ ENDDO
+ ENDIF
+
+ RETURN
+ END
diff --git a/src/splat.F b/src/splat.F
new file mode 100644
index 00000000..3b27073e
--- /dev/null
+++ b/src/splat.F
@@ -0,0 +1,192 @@
+C> @file
+C> @brief Computes cosines of colatitude and Gaussian weights
+C> for sets of latitudes.
+C>
+C> ### Program History Log
+C> Date | Programmer | Comments
+C> -----|------------|---------
+C> 96-02-20 | Iredell | Initial.
+C> 97-10-20 | Iredell | Adjust precision.
+C> 98-06-11 | Iredell | Generalize precision using FORTRAN 90 intrinsic.
+C> 1998-12-03 | Iredell | Generalize precision further.
+C> 1998-12-03 | Iredell | Uses AIX ESSL BLAS calls.
+C> 2009-12-27 | D. Stark | Updated to switch between ESSL calls on an AIX platform, and Numerical Recipies calls elsewise.
+C> 2010-12-30 | Slovacek | Update alignment so preprocessor does not cause compilation failure.
+C> 2012-09-01 | E. Mirvis & M.Iredell | Merging & debugging linux errors of _d and _8 using generic LU factorization.
+C> 2012-11-05 | E. Mirvis | Generic FFTPACK and LU lapack were removed.
+C>
+C> @author Iredell @date 96-02-20
+
+C> Computes cosines of colatitude and Gaussian weights
+C> for one of the following specific global sets of latitudes.
+C> - Gaussian latitudes (IDRT=4)
+C> - Equally-spaced latitudes including poles (IDRT=0)
+C> - Equally-spaced latitudes excluding poles (IDRT=256)
+C>
+C> The Gaussian latitudes are located at the zeroes of the
+C> Legendre polynomial of the given order. These latitudes
+C> are efficient for reversible transforms from spectral space.
+C> (About twice as many equally-spaced latitudes are needed.)
+C> The weights for the equally-spaced latitudes are based on
+C> Ellsaesser (JAM,1966). (No weight is given the pole point.)
+C> Note that when analyzing grid to spectral in latitude pairs,
+C> if an equator point exists, its weight should be halved.
+C> This version invokes the ibm essl matrix solver.
+C>
+C> @param[in] IDRT grid identifier
+C> - 4 for Gaussian grid
+C> - 0 for equally-spaced grid including poles
+C> - 256 for equally-spaced grid excluding poles
+C> @param[in] JMAX number of latitudes
+C> @param[out] SLAT sines of latitude
+C> @param[out] WLAT Gaussian weights
+C>
+C> @author Iredell @date 96-02-20
+ SUBROUTINE SPLAT(IDRT,JMAX,SLAT,WLAT)
+ REAL SLAT(JMAX),WLAT(JMAX)
+ INTEGER,PARAMETER:: KD=SELECTED_REAL_KIND(15,45)
+ REAL(KIND=KD):: PK(JMAX/2),PKM1(JMAX/2),PKM2(JMAX/2)
+ REAL(KIND=KD):: SLATD(JMAX/2),SP,SPMAX,EPS=10.*EPSILON(SP)
+ PARAMETER(JZ=50)
+ REAL BZ(JZ)
+ DATA BZ / 2.4048255577, 5.5200781103,
+ $ 8.6537279129, 11.7915344391, 14.9309177086, 18.0710639679,
+ $ 21.2116366299, 24.3524715308, 27.4934791320, 30.6346064684,
+ $ 33.7758202136, 36.9170983537, 40.0584257646, 43.1997917132,
+ $ 46.3411883717, 49.4826098974, 52.6240518411, 55.7655107550,
+ $ 58.9069839261, 62.0484691902, 65.1899648002, 68.3314693299,
+ $ 71.4729816036, 74.6145006437, 77.7560256304, 80.8975558711,
+ $ 84.0390907769, 87.1806298436, 90.3221726372, 93.4637187819,
+ $ 96.6052679510, 99.7468198587, 102.888374254, 106.029930916,
+ $ 109.171489649, 112.313050280, 115.454612653, 118.596176630,
+ $ 121.737742088, 124.879308913, 128.020877005, 131.162446275,
+ $ 134.304016638, 137.445588020, 140.587160352, 143.728733573,
+ $ 146.870307625, 150.011882457, 153.153458019, 156.295034268 /
+ REAL:: DLT,D1=1.
+ REAL AWORK((JMAX+1)/2,((JMAX+1)/2)),BWORK(((JMAX+1)/2))
+ INTEGER:: JHE,JHO,J0=0
+ INTEGER IPVT((JMAX+1)/2)
+ PARAMETER(PI=3.14159265358979,C=(1.-(2./PI)**2)*0.25)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C GAUSSIAN LATITUDES
+ IF(IDRT.EQ.4) THEN
+ JH=JMAX/2
+ JHE=(JMAX+1)/2
+ R=1./SQRT((JMAX+0.5)**2+C)
+ DO J=1,MIN(JH,JZ)
+ SLATD(J)=COS(BZ(J)*R)
+ ENDDO
+ DO J=JZ+1,JH
+ SLATD(J)=COS((BZ(JZ)+(J-JZ)*PI)*R)
+ ENDDO
+ SPMAX=1.
+ DO WHILE(SPMAX.GT.EPS)
+ SPMAX=0.
+ DO J=1,JH
+ PKM1(J)=1.
+ PK(J)=SLATD(J)
+ ENDDO
+ DO N=2,JMAX
+ DO J=1,JH
+ PKM2(J)=PKM1(J)
+ PKM1(J)=PK(J)
+ PK(J)=((2*N-1)*SLATD(J)*PKM1(J)-(N-1)*PKM2(J))/N
+ ENDDO
+ ENDDO
+ DO J=1,JH
+ SP=PK(J)*(1.-SLATD(J)**2)/(JMAX*(PKM1(J)-SLATD(J)*PK(J)))
+ SLATD(J)=SLATD(J)-SP
+ SPMAX=MAX(SPMAX,ABS(SP))
+ ENDDO
+ ENDDO
+CDIR$ IVDEP
+ DO J=1,JH
+ SLAT(J)=SLATD(J)
+ WLAT(J)=(2.*(1.-SLATD(J)**2))/(JMAX*PKM1(J))**2
+ SLAT(JMAX+1-J)=-SLAT(J)
+ WLAT(JMAX+1-J)=WLAT(J)
+ ENDDO
+ IF(JHE.GT.JH) THEN
+ SLAT(JHE)=0.
+ WLAT(JHE)=2./JMAX**2
+ DO N=2,JMAX,2
+ WLAT(JHE)=WLAT(JHE)*N**2/(N-1)**2
+ ENDDO
+ ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C EQUALLY-SPACED LATITUDES INCLUDING POLES
+ ELSEIF(IDRT.EQ.0) THEN
+ JH=JMAX/2
+ JHE=(JMAX+1)/2
+ JHO=JHE-1
+ DLT=PI/(JMAX-1)
+ SLAT(1)=1.
+ DO J=2,JH
+ SLAT(J)=COS((J-1)*DLT)
+ ENDDO
+ DO JS=1,JHO
+ DO J=1,JHO
+ AWORK(JS,J)=COS(2*(JS-1)*J*DLT)
+ ENDDO
+ ENDDO
+ DO JS=1,JHO
+ BWORK(JS)=-D1/(4*(JS-1)**2-1)
+ ENDDO
+
+ call ludcmp(awork,jho,jhe,ipvt)
+ call lubksb(awork,jho,jhe,ipvt,bwork)
+
+ WLAT(1)=0.
+ DO J=1,JHO
+ WLAT(J+1)=BWORK(J)
+ ENDDO
+CDIR$ IVDEP
+ DO J=1,JH
+ print *, j, jmax, JMAX+1-J
+ SLAT(JMAX+1-J)=-SLAT(J)
+ WLAT(JMAX+1-J)=WLAT(J)
+ ENDDO
+ IF(JHE.GT.JH) THEN
+ SLAT(JHE)=0.
+ WLAT(JHE)=2.*WLAT(JHE)
+ ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C EQUALLY-SPACED LATITUDES EXCLUDING POLES
+ ELSEIF(IDRT.EQ.256) THEN
+ JH=JMAX/2
+ JHE=(JMAX+1)/2
+ JHO=JHE
+ DLT=PI/JMAX
+ SLAT(1)=1.
+ DO J=1,JH
+ SLAT(J)=COS((J-0.5)*DLT)
+ ENDDO
+ DO JS=1,JHO
+ DO J=1,JHO
+ AWORK(JS,J)=COS(2*(JS-1)*(J-0.5)*DLT)
+ ENDDO
+ ENDDO
+ DO JS=1,JHO
+ BWORK(JS)=-D1/(4*(JS-1)**2-1)
+ ENDDO
+
+ call ludcmp(awork,jho,jhe,ipvt,d)
+ call lubksb(awork,jho,jhe,ipvt,bwork)
+
+ WLAT(1)=0.
+ DO J=1,JHO
+ WLAT(J)=BWORK(J)
+ ENDDO
+CDIR$ IVDEP
+ DO J=1,JH
+ SLAT(JMAX+1-J)=-SLAT(J)
+ WLAT(JMAX+1-J)=WLAT(J)
+ ENDDO
+ IF(JHE.GT.JH) THEN
+ SLAT(JHE)=0.
+ WLAT(JHE)=2.*WLAT(JHE)
+ ENDIF
+ ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ RETURN
+ END
diff --git a/src/splegend.f b/src/splegend.f
new file mode 100644
index 00000000..b862ca87
--- /dev/null
+++ b/src/splegend.f
@@ -0,0 +1,131 @@
+C> @file
+C>
+C> Compute Legendre polynomials
+C> @author IREDELL @date 92-10-31
+
+C> Evaluates the orthonormal associated Legendre polynomials in the
+C> spectral domain at a given latitude. Subprogram splegend should
+C> be called already. If l is the zonal wavenumber, N is the total
+C> wavenumber, and EPS(L,N)=SQRT((N**2-L**2)/(4*N**2-1)) then the
+C> following bootstrapping formulas are used:
+C>
+C>
+C> PLN(0,0)=SQRT(0.5)
+C> PLN(L,L)=PLN(L-1,L-1)*CLAT*SQRT(FLOAT(2*L+1)/FLOAT(2*L))
+C> PLN(L,N)=(SLAT*PLN(L,N-1)-EPS(L,N-1)*PLN(L,N-2))/EPS(L,N)
+C>
+C>
+C> Synthesis at the pole needs only two zonal wavenumbers. Scalar
+C> fields are synthesized with zonal wavenumber 0 while vector
+C> fields are synthesized with zonal wavenumber 1. (Thus polar
+C> vector fields are implicitly divided by clat.) The following
+C> bootstrapping formulas are used at the pole:
+C>
+C>
+C> PLN(0,0)=SQRT(0.5)
+C> PLN(1,1)=SQRT(0.75)
+C> PLN(L,N)=(PLN(L,N-1)-EPS(L,N-1)*PLN(L,N-2))/EPS(L,N)
+C>
+C>
+C> PROGRAM HISTORY LOG:
+C> - 91-10-31 MARK IREDELL
+C> - 98-06-10 MARK IREDELL GENERALIZE PRECISION
+C>
+C> @param I - INTEGER SPECTRAL DOMAIN SHAPE
+C> (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL)
+C> @param M - INTEGER SPECTRAL TRUNCATION
+C> @param SLAT - REAL SINE OF LATITUDE
+C> @param CLAT - REAL COSINE OF LATITUDE
+C> @param EPS - REAL ((M+1)*((I+1)*M+2)/2) SQRT((N**2-L**2)/(4*N**2-1))
+C> @param EPSTOP - REAL (M+1) SQRT((N**2-L**2)/(4*N**2-1)) OVER TOP
+C> @param[out] PLN - REAL ((M+1)*((I+1)*M+2)/2) LEGENDRE POLYNOMIAL
+C> @param[out] PLNTOP - REAL (M+1) LEGENDRE POLYNOMIAL OVER TOP
+C>
+ SUBROUTINE SPLEGEND(I,M,SLAT,CLAT,EPS,EPSTOP,PLN,PLNTOP)
+
+CFPP$ NOCONCUR R
+ REAL EPS((M+1)*((I+1)*M+2)/2),EPSTOP(M+1)
+ REAL PLN((M+1)*((I+1)*M+2)/2),PLNTOP(M+1)
+ REAL(KIND=SELECTED_REAL_KIND(15,45)):: DLN((M+1)*((I+1)*M+2)/2)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C ITERATIVELY COMPUTE PLN WITHIN SPECTRAL DOMAIN AT POLE
+ M1=M+1
+ M2=2*M+I+1
+ MX=(M+1)*((I+1)*M+2)/2
+ IF(CLAT.EQ.0.) THEN
+ DLN(1)=SQRT(0.5)
+ IF(M.GT.0) THEN
+ DLN(M1+1)=SQRT(0.75)
+ DLN(2)=SLAT*DLN(1)/EPS(2)
+ ENDIF
+ IF(M.GT.1) THEN
+ DLN(M1+2)=SLAT*DLN(M1+1)/EPS(M1+2)
+ DLN(3)=(SLAT*DLN(2)-EPS(2)*DLN(1))/EPS(3)
+ DO N=3,M
+ K=1+N
+ DLN(K)=(SLAT*DLN(K-1)-EPS(K-1)*DLN(K-2))/EPS(K)
+ K=M1+N
+ DLN(K)=(SLAT*DLN(K-1)-EPS(K-1)*DLN(K-2))/EPS(K)
+ ENDDO
+ IF(I.EQ.1) THEN
+ K=M2
+ DLN(K)=(SLAT*DLN(K-1)-EPS(K-1)*DLN(K-2))/EPS(K)
+ ENDIF
+ DO K=M2+1,MX
+ DLN(K)=0.
+ ENDDO
+ ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C COMPUTE POLYNOMIALS OVER TOP OF SPECTRAL DOMAIN
+ K=M1+1
+ PLNTOP(1)=(SLAT*DLN(K-1)-EPS(K-1)*DLN(K-2))/EPSTOP(1)
+ IF(M.GT.0) THEN
+ K=M2+1
+ PLNTOP(2)=(SLAT*DLN(K-1)-EPS(K-1)*DLN(K-2))/EPSTOP(2)
+ DO L=2,M
+ PLNTOP(L+1)=0.
+ ENDDO
+ ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C ITERATIVELY COMPUTE PLN(L,L) (BOTTOM HYPOTENUSE OF DOMAIN)
+ ELSE
+ NML=0
+ K=1
+ DLN(K)=SQRT(0.5)
+ DO L=1,M+(I-1)*NML
+ KP=K
+ K=L*(2*M+(I-1)*(L-1))/2+L+NML+1
+ DLN(K)=DLN(KP)*CLAT*SQRT(FLOAT(2*L+1)/FLOAT(2*L))
+ ENDDO
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C COMPUTE PLN(L,L+1) (DIAGONAL NEXT TO BOTTOM HYPOTENUSE OF DOMAIN)
+ NML=1
+CDIR$ IVDEP
+ DO L=0,M+(I-1)*NML
+ K=L*(2*M+(I-1)*(L-1))/2+L+NML+1
+ DLN(K)=SLAT*DLN(K-1)/EPS(K)
+ ENDDO
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C COMPUTE REMAINING PLN IN SPECTRAL DOMAIN
+ DO NML=2,M
+CDIR$ IVDEP
+ DO L=0,M+(I-1)*NML
+ K=L*(2*M+(I-1)*(L-1))/2+L+NML+1
+ DLN(K)=(SLAT*DLN(K-1)-EPS(K-1)*DLN(K-2))/EPS(K)
+ ENDDO
+ ENDDO
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C COMPUTE POLYNOMIALS OVER TOP OF SPECTRAL DOMAIN
+ DO L=0,M
+ NML=M+1+(I-1)*L
+ K=L*(2*M+(I-1)*(L-1))/2+L+NML+1
+ PLNTOP(L+1)=(SLAT*DLN(K-1)-EPS(K-1)*DLN(K-2))/EPSTOP(L+1)
+ ENDDO
+ ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C RETURN VALUES
+ DO K=1,MX
+ PLN(K)=DLN(K)
+ ENDDO
+ RETURN
+ END
diff --git a/src/sppad.f b/src/sppad.f
new file mode 100644
index 00000000..6721e44e
--- /dev/null
+++ b/src/sppad.f
@@ -0,0 +1,36 @@
+C> @file
+C> @brief Pad or truncate a spectral field.
+C> @author Iredell @date 92-10-31
+
+C> Pad or truncate a spectral field.
+C>
+C> @param I1 input spectral domain shape
+C> (0 for triangular, 1 for rhomboidal)
+C> @param M1 input spectral truncation
+C> @param Q1 ((M+1)*((I+1)*M+2)) input field
+C> @param I2 output spectral domain shape
+C> (0 for triangular, 1 for rhomboidal)
+C> @param M2 output spectral truncation
+C> @param Q2 ((M+1)*((I+1)*M+2)) output field
+C>
+C> @author Iredell @date 92-10-31
+ SUBROUTINE SPPAD(I1,M1,Q1,I2,M2,Q2)
+
+ REAL Q1((M1+1)*((I1+1)*M1+2))
+ REAL Q2((M2+1)*((I2+1)*M2+2))
+
+ DO L=0,M2
+ DO N=L,I2*L+M2
+ KS2=L*(2*M2+(I2-1)*(L-1))+2*N
+ IF(L.LE.M1.AND.N.LE.I1*L+M1) THEN
+ KS1=L*(2*M1+(I1-1)*(L-1))+2*N
+ Q2(KS2+1)=Q1(KS1+1)
+ Q2(KS2+2)=Q1(KS1+2)
+ ELSE
+ Q2(KS2+1)=0
+ Q2(KS2+2)=0
+ ENDIF
+ ENDDO
+ ENDDO
+ RETURN
+ END
diff --git a/src/spsynth.f b/src/spsynth.f
new file mode 100644
index 00000000..4e0feb99
--- /dev/null
+++ b/src/spsynth.f
@@ -0,0 +1,158 @@
+C> @file
+C> @brief Synthesize Fourier coefficients from spectral coefficients.
+C>
+C> ### Program History Log
+C> Date | Programmer | Comments
+C> -----|------------|---------
+C> 91-10-31 | Mark Iredell | Initial.
+C> 1998-12-18 | Mark Iredell | Include scalar and gradient option.
+C>
+C> @author Iredell @date 92-10-31
+
+C> Synthesizes Fourier coefficients from spectral coefficients
+C> for a latitude pair (Northern and Southern hemispheres).
+C>
+C> Vector components are divided by cosine of latitude.
+C>
+C> @param I spectral domain shape
+C> (0 for triangular, 1 for rhomboidal)
+C> @param M spectral truncation
+C> @param IM even number of Fourier coefficients
+C> @param IX dimension of Fourier coefficients (IX>=IM+2)
+C> @param NC dimension of spectral coefficients
+C> (NC>=(M+1)*((I+1)*M+2))
+C> @param NCTOP dimension of spectral coefficients over top
+C> (NCTOP>=2*(M+1))
+C> @param KM number of fields
+C> @param CLAT cosine of latitude
+C> @param PLN ((M+1)*((I+1)*M+2)/2) Legendre polynomial
+C> @param PLNTOP Legendre polynomial over top
+C> @param SPC spectral coefficients
+C> @param SPCTOP spectral coefficients over top
+C> @param MP identifiers (0 for scalar, 1 for vector,
+C> or 10 for scalar and gradient)
+C> @param F Fourier coefficients for latitude pair
+C>
+C> @author Iredell @date 92-10-31
+ SUBROUTINE SPSYNTH(I,M,IM,IX,NC,NCTOP,KM,CLAT,PLN,PLNTOP,MP,
+ & SPC,SPCTOP,F)
+
+ REAL PLN((M+1)*((I+1)*M+2)/2),PLNTOP(M+1)
+ INTEGER MP(KM)
+ REAL SPC(NC,KM),SPCTOP(NCTOP,KM)
+ REAL F(IX,2,KM)
+
+C ZERO OUT FOURIER COEFFICIENTS.
+ DO K=1,KM
+ DO L=0,IM/2
+ F(2*L+1,1,K)=0.
+ F(2*L+2,1,K)=0.
+ F(2*L+1,2,K)=0.
+ F(2*L+2,2,K)=0.
+ ENDDO
+ ENDDO
+
+C SYNTHESIS OVER POLE.
+C INITIALIZE FOURIER COEFFICIENTS WITH TERMS OVER TOP OF THE SPECTRUM.
+C INITIALIZE EVEN AND ODD POLYNOMIALS SEPARATELY.
+ IF(CLAT.EQ.0) THEN
+ LTOPE=MOD(M+1+I,2)
+!C$OMP PARALLEL DO PRIVATE(LB,LE,L,KS,KP,N,F1R,F1I)
+ DO K=1,KM
+ LB=MP(K)
+ LE=MP(K)
+ IF(MP(K).EQ.10) THEN
+ LB=0
+ LE=1
+ ENDIF
+ L=LB
+ IF(L.EQ.1) THEN
+ IF(L.EQ.LTOPE) THEN
+ F(2*L+1,1,K)=PLNTOP(L+1)*SPCTOP(2*L+1,K)
+ F(2*L+2,1,K)=PLNTOP(L+1)*SPCTOP(2*L+2,K)
+ ELSE
+ F(2*L+1,2,K)=PLNTOP(L+1)*SPCTOP(2*L+1,K)
+ F(2*L+2,2,K)=PLNTOP(L+1)*SPCTOP(2*L+2,K)
+ ENDIF
+ ENDIF
+C FOR EACH ZONAL WAVENUMBER, SYNTHESIZE TERMS OVER TOTAL WAVENUMBER.
+C SYNTHESIZE EVEN AND ODD POLYNOMIALS SEPARATELY.
+ DO L=LB,LE
+ KS=L*(2*M+(I-1)*(L-1))
+ KP=KS/2+1
+ DO N=L,I*L+M,2
+ F(2*L+1,1,K)=F(2*L+1,1,K)+PLN(KP+N)*SPC(KS+2*N+1,K)
+ F(2*L+2,1,K)=F(2*L+2,1,K)+PLN(KP+N)*SPC(KS+2*N+2,K)
+ ENDDO
+ DO N=L+1,I*L+M,2
+ F(2*L+1,2,K)=F(2*L+1,2,K)+PLN(KP+N)*SPC(KS+2*N+1,K)
+ F(2*L+2,2,K)=F(2*L+2,2,K)+PLN(KP+N)*SPC(KS+2*N+2,K)
+ ENDDO
+C SEPARATE FOURIER COEFFICIENTS FROM EACH HEMISPHERE.
+C ODD POLYNOMIALS CONTRIBUTE NEGATIVELY TO THE SOUTHERN HEMISPHERE.
+ F1R=F(2*L+1,1,K)
+ F1I=F(2*L+2,1,K)
+ F(2*L+1,1,K)=F1R+F(2*L+1,2,K)
+ F(2*L+2,1,K)=F1I+F(2*L+2,2,K)
+ F(2*L+1,2,K)=F1R-F(2*L+1,2,K)
+ F(2*L+2,2,K)=F1I-F(2*L+2,2,K)
+ ENDDO
+ ENDDO
+
+C SYNTHESIS OVER FINITE LATITUDE.
+C INITIALIZE FOURIER COEFFICIENTS WITH TERMS OVER TOP OF THE SPECTRUM.
+C INITIALIZE EVEN AND ODD POLYNOMIALS SEPARATELY.
+ ELSE
+ LX=MIN(M,IM/2)
+ LTOPE=MOD(M+1,2)
+ LTOPO=1-LTOPE
+ LE=1+I*LTOPE
+ LO=2-I*LTOPO
+!C$OMP PARALLEL DO PRIVATE(L,KS,KP,N,F1R,F1I)
+ DO K=1,KM
+ IF(MP(K).EQ.1) THEN
+ DO L=LTOPE,LX,2
+ F(2*L+1,LE,K)=PLNTOP(L+1)*SPCTOP(2*L+1,K)
+ F(2*L+2,LE,K)=PLNTOP(L+1)*SPCTOP(2*L+2,K)
+ ENDDO
+ DO L=LTOPO,LX,2
+ F(2*L+1,LO,K)=PLNTOP(L+1)*SPCTOP(2*L+1,K)
+ F(2*L+2,LO,K)=PLNTOP(L+1)*SPCTOP(2*L+2,K)
+ ENDDO
+ ENDIF
+C FOR EACH ZONAL WAVENUMBER, SYNTHESIZE TERMS OVER TOTAL WAVENUMBER.
+C SYNTHESIZE EVEN AND ODD POLYNOMIALS SEPARATELY.
+ DO L=0,LX
+ KS=L*(2*M+(I-1)*(L-1))
+ KP=KS/2+1
+ DO N=L,I*L+M,2
+ F(2*L+1,1,K)=F(2*L+1,1,K)+PLN(KP+N)*SPC(KS+2*N+1,K)
+ F(2*L+2,1,K)=F(2*L+2,1,K)+PLN(KP+N)*SPC(KS+2*N+2,K)
+ ENDDO
+ DO N=L+1,I*L+M,2
+ F(2*L+1,2,K)=F(2*L+1,2,K)+PLN(KP+N)*SPC(KS+2*N+1,K)
+ F(2*L+2,2,K)=F(2*L+2,2,K)+PLN(KP+N)*SPC(KS+2*N+2,K)
+ ENDDO
+ ENDDO
+C SEPARATE FOURIER COEFFICIENTS FROM EACH HEMISPHERE.
+C ODD POLYNOMIALS CONTRIBUTE NEGATIVELY TO THE SOUTHERN HEMISPHERE.
+C DIVIDE VECTOR COMPONENTS BY COSINE LATITUDE.
+ DO L=0,LX
+ F1R=F(2*L+1,1,K)
+ F1I=F(2*L+2,1,K)
+ F(2*L+1,1,K)=F1R+F(2*L+1,2,K)
+ F(2*L+2,1,K)=F1I+F(2*L+2,2,K)
+ F(2*L+1,2,K)=F1R-F(2*L+1,2,K)
+ F(2*L+2,2,K)=F1I-F(2*L+2,2,K)
+ ENDDO
+ IF(MP(K).EQ.1) THEN
+ DO L=0,LX
+ F(2*L+1,1,K)=F(2*L+1,1,K)/CLAT
+ F(2*L+2,1,K)=F(2*L+2,1,K)/CLAT
+ F(2*L+1,2,K)=F(2*L+1,2,K)/CLAT
+ F(2*L+2,2,K)=F(2*L+2,2,K)/CLAT
+ ENDDO
+ ENDIF
+ ENDDO
+ ENDIF
+ END
diff --git a/src/sptez.f b/src/sptez.f
new file mode 100644
index 00000000..87db1063
--- /dev/null
+++ b/src/sptez.f
@@ -0,0 +1,71 @@
+C> @file
+C> @brief Perform a simple scalar spherical transform.
+C> @author Iredell @date 96-02-29
+
+C> This subprogram performs a spherical transform
+C> between spectral coefficients of a scalar quantity
+C> and a field on a global cylindrical grid.
+C>
+C> The wave-space can be either triangular or rhomboidal.
+C>
+C> The grid-space can be either an equally-spaced grid
+C> (with or without pole points) or a Gaussian grid.
+C>
+C> The wave field is in sequential 'IBM ORDER'.
+C>
+C> The grid field is indexed East to West, then North to South.
+C>
+C> For more flexibility and efficiency, call sptran().
+C>
+C> Subprogram can be called from a multiprocessing environment.
+C>
+C> Minimum grid dimensions for unaliased transforms to spectral:
+C> DIMENSION |LINEAR |QUADRATIC
+C> ----------------------- |--------- |-------------
+C> IMAX |2*MAXWV+2 |3*MAXWV/2*2+2
+C> JMAX (IDRT=4,IROMB=0) |1*MAXWV+1 |3*MAXWV/2+1
+C> JMAX (IDRT=4,IROMB=1) |2*MAXWV+1 |5*MAXWV/2+1
+C> JMAX (IDRT=0,IROMB=0) |2*MAXWV+3 |3*MAXWV/2*2+3
+C> JMAX (IDRT=0,IROMB=1) |4*MAXWV+3 |5*MAXWV/2*2+3
+C> JMAX (IDRT=256,IROMB=0) |2*MAXWV+1 |3*MAXWV/2*2+1
+C> JMAX (IDRT=256,IROMB=1) |4*MAXWV+1 |5*MAXWV/2*2+1
+C>
+C> @param IROMB spectral domain shape
+C> (0 for triangular, 1 for rhomboidal)
+C> @param MAXWV spectral truncation
+C> @param IDRT grid identifier
+C> - IDRT=4 for Gaussian grid,
+C> - IDRT=0 for equally-spaced grid including poles,
+C> - IDRT=256 for equally-spaced grid excluding poles
+C> @param IMAX even number of longitudes.
+C> @param JMAX number of latitudes.
+C> @param[out] WAVE wave field if IDIR>0
+C> where MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+C> @param[out] GRID grid field (E->W,N->S) if IDIR<0
+C> @param IDIR transform flag
+C> (IDIR>0 for wave to grid, IDIR<0 for grid to wave).
+C>
+C> @author Iredell @date 96-02-29
+ SUBROUTINE SPTEZ(IROMB,MAXWV,IDRT,IMAX,JMAX,WAVE,GRID,IDIR)
+
+ REAL WAVE((MAXWV+1)*((IROMB+1)*MAXWV+2))
+ REAL GRID(IMAX,JMAX)
+
+ MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+ IP=1
+ IS=1
+ JN=IMAX
+ JS=-JN
+ KW=2*MX
+ KG=IMAX*JMAX
+ JB=1
+ JE=(JMAX+1)/2
+ JC=NCPUS()
+! print *, " EM: SPTEZ:::JJJJJJJJJJJJJJJJJJJCCCCCCCCCCC=" ,JC
+ IF(IDIR.LT.0) WAVE=0
+
+ CALL SPTRANF(IROMB,MAXWV,IDRT,IMAX,JMAX,1,
+ & IP,IS,JN,JS,KW,KG,JB,JE,JC,
+ & WAVE,GRID,GRID(1,JMAX),IDIR)
+
+ END
diff --git a/src/sptezd.f b/src/sptezd.f
new file mode 100644
index 00000000..0c0eaf3c
--- /dev/null
+++ b/src/sptezd.f
@@ -0,0 +1,60 @@
+C> @file
+C> @brief Perform a simple gradient spherical transform.
+C> @author Iredell @date 96-02-29
+
+C> This subprogram performs a spherical transform
+C> between spectral coefficients of a scalar field
+C> and its mean and gradient on a global cylindrical grid.
+C>
+C> The wave-space can be either triangular or rhomboidal.
+C>
+C> The grid-space can be either an equally-spaced grid
+C> (with or without pole points) or a Gaussian grid.
+C>
+C> The wave field is in sequential 'IBM ORDER'.
+C>
+C> The grid fiels is indexed East to West, then North to South.
+C>
+C> For more flexibility and efficiency, call sptran().
+C>
+C> Subprogram can be called from a multiprocessing environment.
+C>
+C> Minimum grid dimensions for unaliased transforms to spectral:
+C> DIMENSION |LINEAR |QUADRATIC
+C> ----------------------- |--------- |-------------
+C> IMAX |2*MAXWV+2 |3*MAXWV/2*2+2
+C> JMAX (IDRT=4,IROMB=0) |1*MAXWV+1 |3*MAXWV/2+1
+C> JMAX (IDRT=4,IROMB=1) |2*MAXWV+1 |5*MAXWV/2+1
+C> JMAX (IDRT=0,IROMB=0) |2*MAXWV+3 |3*MAXWV/2*2+3
+C> JMAX (IDRT=0,IROMB=1) |4*MAXWV+3 |5*MAXWV/2*2+3
+C> JMAX (IDRT=256,IROMB=0) |2*MAXWV+1 |3*MAXWV/2*2+1
+C> JMAX (IDRT=256,IROMB=1) |4*MAXWV+1 |5*MAXWV/2*2+1
+C>
+C> @param IROMB spectral domain shape
+C> (0 for triangular, 1 for rhomboidal)
+C> @param MAXWV spectral truncation
+C> @param IDRT grid identifier
+C> - IDRT=4 for Gaussian grid
+C> - IDRT=0 for equally-spaced grid including poles
+C> - IDRT=256 for equally-spaced grid excluding poles
+C> @param IMAX even number of longitudes.
+C> @param JMAX number of latitudes.
+C> @param[out] WAVE wave field if IDIR>0
+C> @param[out] GRIDMN global mean if IDIR<0
+C> @param[out] GRIDX grid x-gradients (E->W,N->S) if IDIR<0
+C> @param[out] GRIDY grid y-gradients (E->W,N->S) if IDIR<0
+C> @param IDIR transform flag
+C> (IDIR>0 for wave to grid, IDIR<0 for grid to wave).
+C>
+C> @author Iredell @date 96-02-29
+ SUBROUTINE SPTEZD(IROMB,MAXWV,IDRT,IMAX,JMAX,
+ & WAVE,GRIDMN,GRIDX,GRIDY,IDIR)
+
+ REAL WAVE(*),GRIDX(IMAX,JMAX),GRIDY(IMAX,JMAX)
+
+ JC=NCPUS()
+ CALL SPTRAND(IROMB,MAXWV,IDRT,IMAX,JMAX,1,
+ & 0,0,0,0,0,0,0,0,JC,
+ & WAVE,GRIDMN,
+ & GRIDX,GRIDX(1,JMAX),GRIDY,GRIDY(1,JMAX),1)
+ END
diff --git a/src/sptezm.f b/src/sptezm.f
new file mode 100644
index 00000000..1236c5c5
--- /dev/null
+++ b/src/sptezm.f
@@ -0,0 +1,70 @@
+C> @file
+C> @brief Perform simple scalar spherical transforms.
+C> @author Iredell @date 96-02-29
+
+C> This subprogram performs spherical transforms
+C> between spectral coefficients of scalar quantities
+C> and fields on a global cylindrical grid.
+C>
+C> The wave-space can be either triangular or rhomboidal.
+C>
+C> The grid-space can be either an equally-spaced grid
+C> (with or without pole points) or a Gaussian grid.
+C>
+C> Wave fields are in sequential 'IBM ORDER'.
+C>
+C> Grid fields are indexed East to West, then North to South.
+C>
+C> For more flexibility and efficiency, call sptran().
+C>
+C> Subprogram can be called from a multiprocessing environment.
+C>
+C> Minimum grid dimensions for unaliased transforms to spectral:
+C> DIMENSION |LINEAR |QUADRATIC
+C> ----------------------- |--------- |-------------
+C> IMAX |2*MAXWV+2 |3*MAXWV/2*2+2
+C> JMAX (IDRT=4,IROMB=0) |1*MAXWV+1 |3*MAXWV/2+1
+C> JMAX (IDRT=4,IROMB=1) |2*MAXWV+1 |5*MAXWV/2+1
+C> JMAX (IDRT=0,IROMB=0) |2*MAXWV+3 |3*MAXWV/2*2+3
+C> JMAX (IDRT=0,IROMB=1) |4*MAXWV+3 |5*MAXWV/2*2+3
+C> JMAX (IDRT=256,IROMB=0) |2*MAXWV+1 |3*MAXWV/2*2+1
+C> JMAX (IDRT=256,IROMB=1) |4*MAXWV+1 |5*MAXWV/2*2+1
+C>
+C> @param IROMB spectral domain shape
+C> (0 for triangular, 1 for rhomboidal)
+C> @param MAXWV spectral truncation
+C> @param IDRT grid identifier
+C> - IDRT=4 for Gaussian grid
+C> - IDRT=0 for equally-spaced grid including poles
+C> - IDRT=256 for equally-spaced grid excluding poles
+C> @param IMAX even number of longitudes
+C> @param JMAX number of latitudes
+C> @param KMAX number of fields to transform
+C> @param[out] WAVE wave field if IDIR>0
+C> where MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+C> @param[out] GRID grid field (E->W,N->S) if IDIR<0
+C> @param IDIR transform flag
+C> (IDIR>0 for wave to grid, IDIR<0 for grid to wave).
+C>
+C> @author Iredell @date 96-02-29
+ SUBROUTINE SPTEZM(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX,WAVE,GRID,IDIR)
+
+ REAL WAVE((MAXWV+1)*((IROMB+1)*MAXWV+2),KMAX)
+ REAL GRID(IMAX,JMAX,KMAX)
+
+ MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+ IP=1
+ IS=1
+ JN=IMAX
+ JS=-JN
+ KW=2*MX
+ KG=IMAX*JMAX
+ JB=1
+ JE=(JMAX+1)/2
+ JC=NCPUS()
+ IF(IDIR.LT.0) WAVE=0
+
+ CALL SPTRANF(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX,
+ & IP,IS,JN,JS,KW,KG,JB,JE,JC,
+ & WAVE,GRID,GRID(1,JMAX,1),IDIR)
+ END
diff --git a/src/sptezmd.f b/src/sptezmd.f
new file mode 100644
index 00000000..72f0610c
--- /dev/null
+++ b/src/sptezmd.f
@@ -0,0 +1,63 @@
+C> @file
+C> @brief Perform simple gradient spherical transforms.
+C> @author Iredell @date 96-02-29
+
+C> This subprogram performs spherical transforms
+C> between spectral coefficients of scalar fields
+C> and their means and gradients on a global cylindrical grid.
+C>
+C> The wave-space can be either triangular or rhomboidal.
+C>
+C> The grid-space can be either an equally-spaced grid
+C> (with or without pole points) or a gaussian grid.
+C>
+C> The wave fields are in sequential 'IBM ORDER'.
+C>
+C> The grid fields are indexed East to West, then North to South.
+C>
+C> For more flexibility and efficiency, call sptran().
+C>
+C> Subprogram can be called from a multiprocessing environment.
+C>
+C> Minimum grid dimensions for unaliased transforms to spectral:
+C> DIMENSION |LINEAR |QUADRATIC
+C> ----------------------- |--------- |-------------
+C> IMAX |2*MAXWV+2 |3*MAXWV/2*2+2
+C> JMAX (IDRT=4,IROMB=0) |1*MAXWV+1 |3*MAXWV/2+1
+C> JMAX (IDRT=4,IROMB=1) |2*MAXWV+1 |5*MAXWV/2+1
+C> JMAX (IDRT=0,IROMB=0) |2*MAXWV+3 |3*MAXWV/2*2+3
+C> JMAX (IDRT=0,IROMB=1) |4*MAXWV+3 |5*MAXWV/2*2+3
+C> JMAX (IDRT=256,IROMB=0) |2*MAXWV+1 |3*MAXWV/2*2+1
+C> JMAX (IDRT=256,IROMB=1) |4*MAXWV+1 |5*MAXWV/2*2+1
+C>
+C> @param IROMB spectral domain shape
+C> (0 for triangular, 1 for rhomboidal)
+C> @param MAXWV spectral truncation
+C> @param IDRT grid identifier
+C> - IDRT=4 for Gaussian grid
+C> - IDRT=0 for equally-spaced grid including poles
+C> - IDRT=256 for equally-spaced grid excluding poles
+C> @param IMAX even number of longitudes.
+C> @param JMAX number of latitudes.
+C> @param KMAX number
+C> @param[out] WAVE wave field if IDIR>0
+C> where MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)
+C> @param[out] GRIDMN global mean if IDIR<0
+C> @param[out] GRIDX grid x-gradients (E->W,N->S) if IDIR<0
+C> @param[out] GRIDY grid y-gradients (E->W,N->S) if IDIR<0
+C> @param IDIR transform flag
+C> (IDIR>0 for wave to grid, IDIR<0 for grid to wave).
+C>
+C> @author Iredell @date 96-02-29
+ SUBROUTINE SPTEZMD(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX,
+ & WAVE,GRIDMN,GRIDX,GRIDY,IDIR)
+
+ REAL WAVE((MAXWV+1)*((IROMB+1)*MAXWV+2),KMAX)
+ REAL GRIDMN(KMAX),GRIDX(IMAX,JMAX,KMAX),GRIDY(IMAX,JMAX,KMAX)
+
+ JC=NCPUS()
+ CALL SPTRAND(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX,
+ & 0,0,0,0,0,0,0,0,JC,
+ & WAVE,GRIDMN,
+ & GRIDX,GRIDX(1,JMAX,1),GRIDY,GRIDY(1,JMAX,1),IDIR)
+ END
diff --git a/src/sptezmv.f b/src/sptezmv.f
new file mode 100644
index 00000000..79a83378
--- /dev/null
+++ b/src/sptezmv.f
@@ -0,0 +1,78 @@
+C> @file
+C> @brief Perform simple vector spherical transforms.
+C> @author Iredell @date 96-02-29
+
+C> This subprogram performs spherical transforms
+C> between spectral coefficients of divergence and curl
+C> and vector fields on a global cylindrical grid.
+C>
+C> The wave-space can be either triangular or rhomboidal.
+C>
+C> The grid-space can be either an equally-spaced grid
+C> (with or without pole points) or a Gaussian grid.
+C>
+C> Wave fields are in sequential 'IBM ORDER'.
+C>
+C> Grid fields are indexed east to west, then north to south.
+C>
+C> For more flexibility and efficiency, call sptran().
+C>
+C> Subprogram can be called from a multiprocessing environment.
+C>
+C> Minimum grid dimensions for unaliased transforms to spectral:
+C> DIMENSION |LINEAR |QUADRATIC
+C> ----------------------- |--------- |-------------
+C> IMAX |2*MAXWV+2 |3*MAXWV/2*2+2
+C> JMAX (IDRT=4,IROMB=0) |1*MAXWV+1 |3*MAXWV/2+1
+C> JMAX (IDRT=4,IROMB=1) |2*MAXWV+1 |5*MAXWV/2+1
+C> JMAX (IDRT=0,IROMB=0) |2*MAXWV+3 |3*MAXWV/2*2+3
+C> JMAX (IDRT=0,IROMB=1) |4*MAXWV+3 |5*MAXWV/2*2+3
+C> JMAX (IDRT=256,IROMB=0) |2*MAXWV+1 |3*MAXWV/2*2+1
+C> JMAX (IDRT=256,IROMB=1) |4*MAXWV+1 |5*MAXWV/2*2+1
+C>
+C> @param IROMB spectral domain shape
+C> (0 for triangular, 1 for rhomboidal)
+C> @param MAXWV spectral truncation
+C> @param IDRT grid identifier
+C> - IDRT=4 for Gaussian grid
+C> - IDRT=0 for equally-spaced grid including poles
+C> - IDRT=256 for equally-spaced grid excluding poles
+C> @param IMAX even number of longitudes
+C> @param JMAX number of latitudes
+C> @param KMAX number of fields to transform
+C> @param[out] WAVED wave divergence field if IDIR<0
+C> where MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+C> @param[out] WAVEZ wave vorticity field if IDIR>0
+C> where MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+C> @param[out] GRIDU grid u-wind (E->W,N->S) if IDIR>0
+C> @param[out] GRIDV grid v-wind (E->W,N->S) if IDIR>0
+C> @param IDIR transform flag
+C> (IDIR>0 for wave to grid, IDIR<0 for grid to wave).
+C>
+C> @author Iredell @date 96-02-29
+ SUBROUTINE SPTEZMV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX,
+ & WAVED,WAVEZ,GRIDU,GRIDV,IDIR)
+
+ REAL WAVED((MAXWV+1)*((IROMB+1)*MAXWV+2),KMAX)
+ REAL WAVEZ((MAXWV+1)*((IROMB+1)*MAXWV+2),KMAX)
+ REAL GRIDU(IMAX,JMAX,KMAX)
+ REAL GRIDV(IMAX,JMAX,KMAX)
+
+ MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+ IP=1
+ IS=1
+ JN=IMAX
+ JS=-JN
+ KW=2*MX
+ KG=IMAX*JMAX
+ JB=1
+ JE=(JMAX+1)/2
+ JC=NCPUS()
+ IF(IDIR.LT.0) WAVED=0
+ IF(IDIR.LT.0) WAVEZ=0
+
+ CALL SPTRANFV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX,
+ & IP,IS,JN,JS,KW,KG,JB,JE,JC,
+ & WAVED,WAVEZ,
+ & GRIDU,GRIDU(1,JMAX,1),GRIDV,GRIDV(1,JMAX,1),IDIR)
+ END
diff --git a/src/sptezv.f b/src/sptezv.f
new file mode 100644
index 00000000..9a574019
--- /dev/null
+++ b/src/sptezv.f
@@ -0,0 +1,76 @@
+C> @file
+C> @brief Perform a simple vector spherical transform
+C> @author Iredell @date 96-02-29
+
+C> This subprogram performs a spherical transform
+C> between spectral coefficients of divergence and curl
+C> and a vector field on a global cylindrical grid.
+C> The wave-space can be either triangular or rhomboidal.
+C>
+C> The grid-space can be either an equally-spaced grid
+C> (with or without pole points) or a Gaussian grid.
+C>
+C> The wave field is in sequential 'IBM order'.
+C>
+C> The grid field is indexed east to west, then north to south.
+C>
+C> For more flexibility and efficiency, call SPTRAN().
+C>
+C> Subprogram can be called from a multiprocessing environment.
+C>
+C> Minimum grid dimensions for unaliased transforms to spectral:
+C> Dimension |Linear |Quadratic
+C> ----------------------- |--------- |-------------
+C> IMAX |2*MAXWV+2 |3*MAXWV/2*2+2
+C> JMAX (IDRT=4,IROMB=0) |1*MAXWV+1 |3*MAXWV/2+1
+C> JMAX (IDRT=4,IROMB=1) |2*MAXWV+1 |5*MAXWV/2+1
+C> JMAX (IDRT=0,IROMB=0) |2*MAXWV+3 |3*MAXWV/2*2+3
+C> JMAX (IDRT=0,IROMB=1) |4*MAXWV+3 |5*MAXWV/2*2+3
+C> JMAX (IDRT=256,IROMB=0) |2*MAXWV+1 |3*MAXWV/2*2+1
+C> JMAX (IDRT=256,IROMB=1) |4*MAXWV+1 |5*MAXWV/2*2+1
+C>
+C> @param IROMB Spectral domain shape
+C> (0 for triangular, 1 for rhomboidal)
+C> @param MAXWV Spectral truncation
+C> @param IDRT Grid identifier
+C> - IDRT=4 for Gaussian grid
+C> - IDRT=0 for equally-spaced grid including poles
+C> - IDRT=256 for equally-spaced grid excluding poles
+C> @param IMAX Even number of longitudes
+C> @param JMAX Number of latitudes
+C> @param[out] WAVED Wave divergence field if IDIR>0
+C> where MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+C> @param[out] WAVEZ Wave vorticity field if IDIR>0
+C> where MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+C> @param[out] GRIDU Grid u-wind (E->W,N->S) if IDIR<0
+C> @param[out] GRIDV Grid v-wind (E->W,N->S) if IDIR<0
+C> @param IDIR Transform flag
+C> (IDIR>0 for wave to grid, IDIR<0 for grid to wave)
+C>
+C> @author Iredell @date 96-02-29
+ SUBROUTINE SPTEZV(IROMB,MAXWV,IDRT,IMAX,JMAX,
+ & WAVED,WAVEZ,GRIDU,GRIDV,IDIR)
+
+ REAL WAVED((MAXWV+1)*((IROMB+1)*MAXWV+2))
+ REAL WAVEZ((MAXWV+1)*((IROMB+1)*MAXWV+2))
+ REAL GRIDU(IMAX,JMAX)
+ REAL GRIDV(IMAX,JMAX)
+
+ MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+ IP=1
+ IS=1
+ JN=IMAX
+ JS=-JN
+ KW=2*MX
+ KG=IMAX*JMAX
+ JB=1
+ JE=(JMAX+1)/2
+ JC=NCPUS()
+ IF(IDIR.LT.0) WAVED=0
+ IF(IDIR.LT.0) WAVEZ=0
+
+ CALL SPTRANFV(IROMB,MAXWV,IDRT,IMAX,JMAX,1,
+ & IP,IS,JN,JS,KW,KG,JB,JE,JC,
+ & WAVED,WAVEZ,
+ & GRIDU,GRIDU(1,JMAX),GRIDV,GRIDV(1,JMAX),IDIR)
+ END
diff --git a/src/sptgpm.f b/src/sptgpm.f
new file mode 100644
index 00000000..44325d27
--- /dev/null
+++ b/src/sptgpm.f
@@ -0,0 +1,124 @@
+C> @file
+C> @brief Transform spectral scalar to Mercator
+C> ### Program history log:
+C> Date | Programmer | Comments
+C> -----------|------------|---------
+C> 96-02-29 | IREDELL | Initial.
+C> 1998-12-15 | IREDELL | OpenMP directives inserted.
+C> @author IREDELL @date 96-02-29
+
+C> This subprogram performs a spherical transform
+C> from spectral coefficients of scalar quantities
+C> to scalar fields on a Mercator grid.
+C> The wave-space can be either triangular or rhomboidal.
+C> The wave and grid fields may have general indexing,
+C> but each wave field is in sequential 'ibm order',
+C> i.e. with zonal wavenumber as the slower index.
+C> The Mercator grid is identified by the location
+C> of its first point and by its respective increments.
+C> The transforms are all multiprocessed over sector points.
+C> Transform several fields at a time to improve vectorization.
+C> Subprogram can be called from a multiprocessing environment.
+C>
+C> @param IROMB Spectral domain shape
+C> (0 for triangular, 1 for rhomboidal)
+C> @param MAXWV Spectral truncation
+C> @param KMAX Number of fields to transform
+C> @param MI Number of points in the faster zonal direction
+C> @param MJ Number of points in the slower merid direction
+C> @param KWSKIP Skip number between wave fields
+C> (defaults to (MAXWV+1)*((IROMB+1)*MAXWV+2) if KWSKIP=0)
+C> @param KGSKIP Skip number between grid fields
+C> (defaults to MI*MJ if KGSKIP=0)
+C> @param NISKIP Skip number between grid i-points
+C> (defaults to 1 if NISKIP=0)
+C> @param NJSKIP Skip number between grid j-points
+C> (defaults to MI if NJSKIP=0)
+C> @param RLAT1 Latitude of the first grid point in degrees
+C> @param RLON1 Longitude of the first grid point in degrees
+C> @param DLAT Latitude increment in degrees such that
+C> D(PHI)/D(J)=DLAT*COS(PHI) where J is meridional index.
+C> DLAT is negative for grids indexed southward.
+C> (in terms of grid increment DY valid at latitude RLATI,
+C> the latitude increment DLAT is determined as
+C> DLAT=DPR*DY/(RERTH*COS(RLATI/DPR))
+C> where DPR=180/PI and RERTH is earth's radius)
+C> @param DLON Longitude increment in degrees such that
+C> D(LAMBDA)/D(I)=DLON where I is zonal index.
+C> DLON is negative for grids indexed westward.
+C> @param WAVE Wave fields
+C> @param GM Mercator fields
+C>
+C> @author IREDELL @date 96-02-29
+ SUBROUTINE SPTGPM(IROMB,MAXWV,KMAX,MI,MJ,
+ & KWSKIP,KGSKIP,NISKIP,NJSKIP,
+ & RLAT1,RLON1,DLAT,DLON,WAVE,GM)
+
+ REAL WAVE(*),GM(*)
+ REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1)
+ REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1)
+ INTEGER MP(KMAX)
+ REAL WTOP(2*(MAXWV+1),KMAX)
+ REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),PLNTOP(MAXWV+1)
+ REAL F(2*MAXWV+3,2,KMAX)
+ REAL CLAT(MJ),SLAT(MJ),CLON(MAXWV,MI),SLON(MAXWV,MI)
+ PARAMETER(RERTH=6.3712E6)
+ PARAMETER(PI=3.14159265358979,DPR=180./PI)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C CALCULATE PRELIMINARY CONSTANTS
+ CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP)
+ MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+ MXTOP=MAXWV+1
+ IDIM=2*MAXWV+3
+ KW=KWSKIP
+ KG=KGSKIP
+ NI=NISKIP
+ NJ=NJSKIP
+ IF(KW.EQ.0) KW=2*MX
+ IF(KG.EQ.0) KG=MI*MJ
+ IF(NI.EQ.0) NI=1
+ IF(NJ.EQ.0) NJ=MI
+ DO I=1,MI
+ RLON=MOD(RLON1+DLON*(I-1)+3600,360.)
+ DO L=1,MAXWV
+ CLON(L,I)=COS(L*RLON/DPR)
+ SLON(L,I)=SIN(L*RLON/DPR)
+ ENDDO
+ ENDDO
+ YE=1-LOG(TAN((RLAT1+90)/2/DPR))*DPR/DLAT
+ DO J=1,MJ
+ RLAT=ATAN(EXP(DLAT/DPR*(J-YE)))*2*DPR-90
+ CLAT(J)=COS(RLAT/DPR)
+ SLAT(J)=SIN(RLAT/DPR)
+ ENDDO
+ MP=0
+C$OMP PARALLEL DO
+ DO K=1,KMAX
+ WTOP(1:2*MXTOP,K)=0
+ ENDDO
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C TRANSFORM TO GRID
+C$OMP PARALLEL DO PRIVATE(PLN,PLNTOP,F,IJK)
+ DO J=1,MJ
+ CALL SPLEGEND(IROMB,MAXWV,SLAT(J),CLAT(J),EPS,EPSTOP,
+ & PLN,PLNTOP)
+ CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,KW,2*MXTOP,KMAX,
+ & CLAT(J),PLN,PLNTOP,MP,WAVE,WTOP,F)
+ DO K=1,KMAX
+ DO I=1,MI
+ IJK=(I-1)*NI+(J-1)*NJ+(K-1)*KG+1
+ GM(IJK)=F(1,1,K)
+ ENDDO
+ DO L=1,MAXWV
+ DO I=1,MI
+ IJK=(I-1)*NI+(J-1)*NJ+(K-1)*KG+1
+ GM(IJK)=GM(IJK)+2.*(F(2*L+1,1,K)*CLON(L,I)
+ & -F(2*L+2,1,K)*SLON(L,I))
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ END
diff --git a/src/sptgpmd.f b/src/sptgpmd.f
new file mode 100644
index 00000000..4aefb160
--- /dev/null
+++ b/src/sptgpmd.f
@@ -0,0 +1,81 @@
+C> @file
+C> @brief Transform spectral to Mercator gradients.
+C> @author Iredell @date 96-02-29
+
+C> This subprogram performs a spherical transform
+C> from spectral coefficients of scalar fields
+C> to gradient fields on a Mercator grid.
+C>
+C> The wave-space can be either triangular or rhomboidal.
+C> The wave and grid fields may have general indexing,
+C> but each wave field is in sequential 'IBM order',
+C> i.e. with zonal wavenumber as the slower index.
+C>
+C> The Mercator grid is identified by the location
+C> of its first point and by its respective increments.
+C>
+C> The transforms are all multiprocessed over sector points.
+C>
+C> Transform several fields at a time to improve vectorization.
+C> Subprogram can be called from a multiprocessing environment.
+C>
+C> @param IROMB Spectral domain shape
+C> (0 for triangular, 1 for rhomboidal)
+C> @param MAXWV Spectral truncation
+C> @param KMAX Number of fields to transform
+C> @param MI Number of points in the faster zonal direction
+C> @param MJ Number of points in the slower merid direction
+C> @param KWSKIP Skip number between wave fields
+C> (defaults to (MAXWV+1)*((IROMB+1)*MAXWV+2) if KWSKIP=0)
+C> @param KGSKIP Skip number between grid fields
+C> (defaults to MI*MJ if KGSKIP=0)
+C> @param NISKIP Skip number between grid i-points
+C> (defaults to 1 if NISKIP=0)
+C> @param NJSKIP Skip number between grid j-points
+C> (defaults to MI if NJSKIP=0)
+C> @param RLAT1 Latitude of the first grid point in degrees
+C> @param RLON1 Longitude of the first grid point in degrees
+C> @param DLAT Latitude increment in degrees such that
+C> D(PHI)/D(J)=DLAT*COS(PHI) where J is meridional index.
+C> DLAT is negative for grids indexed southward.
+C> (in terms of grid increment dy valid at latitude RLATI,
+C> the latitude increment DLAT is determined as
+C> DLAT=DPR*DY/(RERTH*COS(RLATI/DPR))
+C> where DPR=180/PI and RERTH is Earth's radius)
+C> @param DLON Longitude increment in degrees such that
+C> D(LAMBDA)/D(I)=DLON where I is zonal index.
+C> DLON is negative for grids indexed westward.
+C> @param WAVE Wave fields
+C> @param XM Mercator x-gradients
+C> @param YM Mercator y-gradients
+C>
+C> @author Iredell @date 96-02-29
+ SUBROUTINE SPTGPMD(IROMB,MAXWV,KMAX,MI,MJ,
+ & KWSKIP,KGSKIP,NISKIP,NJSKIP,
+ & RLAT1,RLON1,DLAT,DLON,WAVE,XM,YM)
+
+ REAL WAVE(*),XM(*),YM(*)
+ REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1)
+ REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1)
+ REAL WD((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX)
+ REAL WZ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX)
+
+C CALCULATE PRELIMINARY CONSTANTS
+ CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP)
+ MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+ MDIM=2*MX+1
+ KW=KWSKIP
+ IF(KW.EQ.0) KW=2*MX
+
+C CALCULATE GRADIENTS
+C$OMP PARALLEL DO PRIVATE(KWS)
+ DO K=1,KMAX
+ KWS=(K-1)*KW
+ CALL SPLAPLAC(IROMB,MAXWV,ENN1,WAVE(KWS+1),WD(1,K),1)
+ WZ(1:2*MX,K)=0.
+ ENDDO
+ CALL SPTGPMV(IROMB,MAXWV,KMAX,MI,MJ,MDIM,KGSKIP,NISKIP,NJSKIP,
+ & RLAT1,RLON1,DLAT,DLON,WD,WZ,XM,YM)
+ END
diff --git a/src/sptgpmv.f b/src/sptgpmv.f
new file mode 100644
index 00000000..c153a09c
--- /dev/null
+++ b/src/sptgpmv.f
@@ -0,0 +1,143 @@
+C> @file
+C> @brief Transform spectral vector to Mercator
+C> ### Program history log:
+C> Date | Programmer | Comments
+C> -----|------------|----------
+C> 96-02-29 | IREDELL | Initial.
+C> 1998-12-15 | IREDELL | OpenMP directives inserted.
+C> @author IREDELL @date 96-02-29
+
+C> This subprogram performs a spherical transform
+C> from spectral coefficients of divergences and curls
+C> to vector fields on a Mercator grid.
+C>
+C> The wave-space can be either triangular or rhomboidal.
+C>
+C> The wave and grid fields may have general indexing,
+C> but each wave field is in sequential 'ibm order',
+C> i.e., with zonal wavenumber as the slower index.
+C>
+C> The Mercator grid is identified by the location
+C> of its first point and by its respective increments.
+C>
+C> The transforms are all multiprocessed over sector points.
+C> Transform several fields at a time to improve vectorization.
+C>
+C> Subprogram can be called from a multiprocessing environment.
+C>
+C> @param IROMB Spectral domain shape
+C> (0 for triangular, 1 for rhomboidal)
+C> @param MAXWV Spectral truncation
+C> @param KMAX Number of fields to transform
+C> @param MI Number of points in the faster zonal direction
+C> @param MJ Number of points in the slower merid direction
+C> @param KWSKIP Skip number between wave fields
+C> (defaults to (MAXWV+1)*((IROMB+1)*MAXWV+2) if KWSKIP=0)
+C> @param KGSKIP Skip number between grid fields
+C> (defaults to MI*MJ if KGSKIP=0)
+C> @param NISKIP Skip number between grid i-points
+C> (defaults to 1 if NISKIP=0)
+C> @param NJSKIP Skip number between grid j-points
+C> (defaults to MI if NJSKIP=0)
+C> @param RLAT1 Latitude of the first grid point in degrees
+C> @param RLON1 Longitude of the first grid point in degrees
+C> @param DLAT Latitude increment in degrees such that
+C> D(PHI)/D(J)=DLAT*COS(PHI) where J is meridional index.
+C> DLAT is negative for grids indexed southward.
+C> (in terms of grid increment dy valid at latitude RLATI,
+C> The latitude increment DLAT is determined as
+C> DLAT=DPR*DY/(RERTH*COS(RLATI/DPR))
+C> where DPR=180/PI and RERTH is Earth's radius)
+C> @param DLON longitude increment in degrees such that
+C> D(LAMBDA)/D(I)=DLON where I is zonal index.
+C> DLON is negative for grids indexed westward.
+C> @param WAVED Wave divergence fields
+C> @param WAVEZ Wave vorticity fields
+C> @param UM Mercator u-winds
+C> @param VM Mercator v-winds
+C>
+C> @author IREDELL @date 96-02-29
+ SUBROUTINE SPTGPMV(IROMB,MAXWV,KMAX,MI,MJ,
+ & KWSKIP,KGSKIP,NISKIP,NJSKIP,
+ & RLAT1,RLON1,DLAT,DLON,WAVED,WAVEZ,UM,VM)
+
+ REAL WAVED(*),WAVEZ(*),UM(*),VM(*)
+ REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1)
+ REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1)
+ INTEGER MP(2*KMAX)
+ REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,2*KMAX)
+ REAL WTOP(2*(MAXWV+1),2*KMAX)
+ REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),PLNTOP(MAXWV+1)
+ REAL F(2*MAXWV+3,2,2*KMAX)
+ REAL CLAT(MJ),SLAT(MJ),CLON(MAXWV,MI),SLON(MAXWV,MI)
+ PARAMETER(RERTH=6.3712E6)
+ PARAMETER(PI=3.14159265358979,DPR=180./PI)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C CALCULATE PRELIMINARY CONSTANTS
+ CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP)
+ MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+ MXTOP=MAXWV+1
+ MDIM=2*MX+1
+ IDIM=2*MAXWV+3
+ KW=KWSKIP
+ KG=KGSKIP
+ NI=NISKIP
+ NJ=NJSKIP
+ IF(KW.EQ.0) KW=2*MX
+ IF(KG.EQ.0) KG=MI*MJ
+ IF(NI.EQ.0) NI=1
+ IF(NJ.EQ.0) NJ=MI
+ DO I=1,MI
+ RLON=MOD(RLON1+DLON*(I-1)+3600,360.)
+ DO L=1,MAXWV
+ CLON(L,I)=COS(L*RLON/DPR)
+ SLON(L,I)=SIN(L*RLON/DPR)
+ ENDDO
+ ENDDO
+ YE=1-LOG(TAN((RLAT1+90)/2/DPR))*DPR/DLAT
+ DO J=1,MJ
+ RLAT=ATAN(EXP(DLAT/DPR*(J-YE)))*2*DPR-90
+ CLAT(J)=COS(RLAT/DPR)
+ SLAT(J)=SIN(RLAT/DPR)
+ ENDDO
+ MP=1
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C CALCULATE SPECTRAL WINDS
+C$OMP PARALLEL DO PRIVATE(KWS)
+ DO K=1,KMAX
+ KWS=(K-1)*KW
+ CALL SPDZ2UV(IROMB,MAXWV,ENN1,ELONN1,EON,EONTOP,
+ & WAVED(KWS+1),WAVEZ(KWS+1),
+ & W(1,K),W(1,KMAX+K),WTOP(1,K),WTOP(1,KMAX+K))
+ ENDDO
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C TRANSFORM TO GRID
+C$OMP PARALLEL DO PRIVATE(PLN,PLNTOP,F,KU,KV,IJK)
+ DO J=1,MJ
+ CALL SPLEGEND(IROMB,MAXWV,SLAT(J),CLAT(J),EPS,EPSTOP,
+ & PLN,PLNTOP)
+ CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,MDIM,2*MXTOP,2*KMAX,
+ & CLAT(J),PLN,PLNTOP,MP,W,WTOP,F)
+ DO K=1,KMAX
+ KU=K
+ KV=K+KMAX
+ DO I=1,MI
+ IJK=(I-1)*NI+(J-1)*NJ+(K-1)*KG+1
+ UM(IJK)=F(1,1,KU)
+ VM(IJK)=F(1,1,KV)
+ ENDDO
+ DO L=1,MAXWV
+ DO I=1,MI
+ IJK=(I-1)*NI+(J-1)*NJ+(K-1)*KG+1
+ UM(IJK)=UM(IJK)+2.*(F(2*L+1,1,KU)*CLON(L,I)
+ & -F(2*L+2,1,KU)*SLON(L,I))
+ VM(IJK)=VM(IJK)+2.*(F(2*L+1,1,KV)*CLON(L,I)
+ & -F(2*L+2,1,KV)*SLON(L,I))
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ END
diff --git a/src/sptgps.f b/src/sptgps.f
new file mode 100644
index 00000000..481e2d1f
--- /dev/null
+++ b/src/sptgps.f
@@ -0,0 +1,547 @@
+C> @file
+C> @brief Transform spectral scalar to polar stereo.
+C>
+C> ### Program History Log
+C> Date | Programmer | Comments
+C> -----|------------|---------
+C> 96-02-29 | Iredell | Initial.
+C> 1998-12-15 | Iredell | Openmp directives inserted.
+C>
+C> @author Iredell @date 96-02-29
+
+C> This subprogram performs a spherical transform
+C> from spectral coefficients of scalar quantities
+C> to scalar fields on a pair of polar stereographic grids.
+C>
+C> The wave-space can be either triangular or rhomboidal.
+C>
+C> The wave and grid fields may have general indexing,
+C> but each wave field is in sequential 'IBM order',
+C> i.e. with zonal wavenumber as the slower index.
+C>
+C> The two square polar stereographic grids are centered
+C> on the respective poles, with the orientation longitude
+C> of the southern hemisphere grid 180 degrees opposite
+C> that of the northern hemisphere grid.
+C>
+C> The transform is made efficient
+C> by combining points in eight sectors
+C> of each polar stereographic grid,
+C> numbered as in the diagram below.
+C>
+C> The pole and the sector boundaries
+C> are treated specially in the code.
+C>
+C> Unfortunately, this approach induces
+C> some hairy indexing and code loquacity.
+C>
+C>
+C> \ 4 | 5 /
+C> \ | /
+C> 3 \ | / 6
+C> \|/
+C> ----+----
+C> /|\
+C> 2 / | \ 7
+C> / | \
+C> / 1 | 8 \
+C>
+C>
+C> The transforms are all multiprocessed over sector points.
+C>
+C> Transform several fields at a time to improve vectorization.
+C>
+C> Subprogram can be called from a multiprocessing environment.
+C>
+C> @param IROMB spectral domain shape
+C> (0 for triangular, 1 for rhomboidal)
+C> @param MAXWV spectral truncation
+C> @param KMAX number of fields to transform.
+C> @param NPS odd order of the polar stereographic grids.
+C> @param KWSKIP skip number between wave fields
+C> (defaults to (MAXWV+1)*((IROMB+1)*MAXWV+2) if KWSKIP=0)
+C> @param KGSKIP skip number between grid fields
+C> (defaults to NPS*NPS if KGSKIP=0)
+C> @param NISKIP skip number between grid i-points
+C> (defaults to 1 if NISKIP=0)
+C> @param NJSKIP skip number between grid j-points
+C> (defaults to NPS if NJSKIP=0)
+C> @param TRUE latitude at which ps grid is true (usually 60.)
+C> @param XMESH grid length at true latitude (m)
+C> @param ORIENT longitude at bottom of northern ps grid
+C> (southern ps grid will have opposite orientation.)
+C> @param WAVE wave fields
+C> @param GN northern polar stereographic fields
+C> @param GS southern polar stereographic fields
+C>
+C> @author Iredell @date 96-02-29
+ SUBROUTINE SPTGPS(IROMB,MAXWV,KMAX,NPS,
+ & KWSKIP,KGSKIP,NISKIP,NJSKIP,
+ & TRUE,XMESH,ORIENT,WAVE,GN,GS)
+
+ REAL WAVE(*),GN(*),GS(*)
+ REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1)
+ REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1)
+ INTEGER MP(KMAX)
+ REAL SLON(MAXWV,8),CLON(MAXWV,8),SROT(0:3),CROT(0:3)
+ REAL WTOP(2*(MAXWV+1),KMAX)
+ REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),PLNTOP(MAXWV+1)
+ REAL F(2*MAXWV+3,2,KMAX)
+ DATA SROT/0.,1.,0.,-1./,CROT/1.,0.,-1.,0./
+ PARAMETER(RERTH=6.3712E6)
+ PARAMETER(PI=3.14159265358979,DPR=180./PI)
+
+C CALCULATE PRELIMINARY CONSTANTS
+ CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP)
+ MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+ MXTOP=MAXWV+1
+ IDIM=2*MAXWV+3
+ KW=KWSKIP
+ KG=KGSKIP
+ NI=NISKIP
+ NJ=NJSKIP
+ IF(KW.EQ.0) KW=2*MX
+ IF(KG.EQ.0) KG=NPS*NPS
+ IF(NI.EQ.0) NI=1
+ IF(NJ.EQ.0) NJ=NPS
+ MP=0
+ NPH=(NPS-1)/2
+ GQ=((1.+SIN(TRUE/DPR))*RERTH/XMESH)**2
+C$OMP PARALLEL DO
+ DO K=1,KMAX
+ WTOP(1:2*MXTOP,K)=0
+ ENDDO
+
+C CALCULATE POLE POINT
+ I1=NPH+1
+ J1=NPH+1
+ IJ1=(I1-1)*NI+(J1-1)*NJ+1
+ SLAT1=1.
+ CLAT1=0.
+ CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP,
+ & PLN,PLNTOP)
+ CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,KW,2*MXTOP,KMAX,
+ & CLAT1,PLN,PLNTOP,MP,WAVE,WTOP,F)
+CDIR$ IVDEP
+ DO K=1,KMAX
+ IJK1=IJ1+(K-1)*KG
+ GN(IJK1)=F(1,1,K)
+ GS(IJK1)=F(1,2,K)
+ ENDDO
+
+C CALCULATE POINTS ALONG THE ROW AND COLUMN OF THE POLE,
+C STARTING AT THE ORIENTATION LONGITUDE AND GOING CLOCKWISE.
+C$OMP PARALLEL DO PRIVATE(I1,J2,I2,J3,I3,J4,I4,J5,I5,J6,I6,J7,I7,J8,I8)
+C$OMP& PRIVATE(IJ1,IJ2,IJ3,IJ4,IJ5,IJ6,IJ7,IJ8)
+C$OMP& PRIVATE(IJK1,IJK2,IJK3,IJK4,IJK5,IJK6,IJK7,IJK8)
+C$OMP& PRIVATE(DJ1,DI1,RQ,RADLON,RADLON1,RADLON2,SLAT1,CLAT1)
+C$OMP& PRIVATE(PLN,PLNTOP,F,SLON,CLON,LR,LI)
+ DO J1=1,NPH
+ I1=NPH+1
+ RADLON=ORIENT/DPR
+ J3=NPS+1-I1
+ I3=J1
+ J5=NPS+1-J1
+ I5=NPS+1-I1
+ J7=I1
+ I7=NPS+1-J1
+ IJ1=(I1-1)*NI+(J1-1)*NJ+1
+ IJ3=(I3-1)*NI+(J3-1)*NJ+1
+ IJ5=(I5-1)*NI+(J5-1)*NJ+1
+ IJ7=(I7-1)*NI+(J7-1)*NJ+1
+ DI1=I1-NPH-1
+ DJ1=J1-NPH-1
+ RQ=DI1**2+DJ1**2
+ SLAT1=(GQ-RQ)/(GQ+RQ)
+ CLAT1=SQRT(1.-SLAT1**2)
+ CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP,
+ & PLN,PLNTOP)
+ CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,KW,2*MXTOP,KMAX,
+ & CLAT1,PLN,PLNTOP,MP,WAVE,WTOP,F)
+ DO L=1,MAXWV
+ SLON(L,1)=SIN(L*RADLON)
+ CLON(L,1)=COS(L*RADLON)
+ SLON(L,3)=SLON(L,1)*CROT(MOD(1*L,4))
+ & -CLON(L,1)*SROT(MOD(1*L,4))
+ CLON(L,3)=CLON(L,1)*CROT(MOD(1*L,4))
+ & +SLON(L,1)*SROT(MOD(1*L,4))
+ SLON(L,5)=SLON(L,1)*CROT(MOD(2*L,4))
+ & -CLON(L,1)*SROT(MOD(2*L,4))
+ CLON(L,5)=CLON(L,1)*CROT(MOD(2*L,4))
+ & +SLON(L,1)*SROT(MOD(2*L,4))
+ SLON(L,7)=SLON(L,1)*CROT(MOD(3*L,4))
+ & -CLON(L,1)*SROT(MOD(3*L,4))
+ CLON(L,7)=CLON(L,1)*CROT(MOD(3*L,4))
+ & +SLON(L,1)*SROT(MOD(3*L,4))
+ ENDDO
+CDIR$ IVDEP
+ DO K=1,KMAX
+ IJK1=IJ1+(K-1)*KG
+ IJK3=IJ3+(K-1)*KG
+ IJK5=IJ5+(K-1)*KG
+ IJK7=IJ7+(K-1)*KG
+ GN(IJK1)=F(1,1,K)
+ GN(IJK3)=F(1,1,K)
+ GN(IJK5)=F(1,1,K)
+ GN(IJK7)=F(1,1,K)
+ GS(IJK1)=F(1,2,K)
+ GS(IJK3)=F(1,2,K)
+ GS(IJK5)=F(1,2,K)
+ GS(IJK7)=F(1,2,K)
+ ENDDO
+ IF(KMAX.EQ.1) THEN
+ DO L=1,MAXWV
+ LR=2*L+1
+ LI=2*L+2
+ GN(IJ1)=GN(IJ1)+2*(F(LR,1,1)*CLON(L,1)
+ & -F(LI,1,1)*SLON(L,1))
+ GN(IJ3)=GN(IJ3)+2*(F(LR,1,1)*CLON(L,3)
+ & -F(LI,1,1)*SLON(L,3))
+ GN(IJ5)=GN(IJ5)+2*(F(LR,1,1)*CLON(L,5)
+ & -F(LI,1,1)*SLON(L,5))
+ GN(IJ7)=GN(IJ7)+2*(F(LR,1,1)*CLON(L,7)
+ & -F(LI,1,1)*SLON(L,7))
+ GS(IJ1)=GS(IJ1)+2*(F(LR,2,1)*CLON(L,5)
+ & -F(LI,2,1)*SLON(L,5))
+ GS(IJ3)=GS(IJ3)+2*(F(LR,2,1)*CLON(L,3)
+ & -F(LI,2,1)*SLON(L,3))
+ GS(IJ5)=GS(IJ5)+2*(F(LR,2,1)*CLON(L,1)
+ & -F(LI,2,1)*SLON(L,1))
+ GS(IJ7)=GS(IJ7)+2*(F(LR,2,1)*CLON(L,7)
+ & -F(LI,2,1)*SLON(L,7))
+ ENDDO
+ ELSE
+ DO L=1,MAXWV
+ LR=2*L+1
+ LI=2*L+2
+CDIR$ IVDEP
+ DO K=1,KMAX
+ IJK1=IJ1+(K-1)*KG
+ IJK3=IJ3+(K-1)*KG
+ IJK5=IJ5+(K-1)*KG
+ IJK7=IJ7+(K-1)*KG
+ GN(IJK1)=GN(IJK1)+2*(F(LR,1,K)*CLON(L,1)
+ & -F(LI,1,K)*SLON(L,1))
+ GN(IJK3)=GN(IJK3)+2*(F(LR,1,K)*CLON(L,3)
+ & -F(LI,1,K)*SLON(L,3))
+ GN(IJK5)=GN(IJK5)+2*(F(LR,1,K)*CLON(L,5)
+ & -F(LI,1,K)*SLON(L,5))
+ GN(IJK7)=GN(IJK7)+2*(F(LR,1,K)*CLON(L,7)
+ & -F(LI,1,K)*SLON(L,7))
+ GS(IJK1)=GS(IJK1)+2*(F(LR,2,K)*CLON(L,5)
+ & -F(LI,2,K)*SLON(L,5))
+ GS(IJK3)=GS(IJK3)+2*(F(LR,2,K)*CLON(L,3)
+ & -F(LI,2,K)*SLON(L,3))
+ GS(IJK5)=GS(IJK5)+2*(F(LR,2,K)*CLON(L,1)
+ & -F(LI,2,K)*SLON(L,1))
+ GS(IJK7)=GS(IJK7)+2*(F(LR,2,K)*CLON(L,7)
+ & -F(LI,2,K)*SLON(L,7))
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDDO
+
+C CALCULATE POINTS ON THE MAIN DIAGONALS THROUGH THE POLE,
+C STARTING CLOCKWISE OF THE ORIENTATION LONGITUDE AND GOING CLOCKWISE.
+C$OMP PARALLEL DO PRIVATE(I1,J2,I2,J3,I3,J4,I4,J5,I5,J6,I6,J7,I7,J8,I8)
+C$OMP& PRIVATE(IJ1,IJ2,IJ3,IJ4,IJ5,IJ6,IJ7,IJ8)
+C$OMP& PRIVATE(IJK1,IJK2,IJK3,IJK4,IJK5,IJK6,IJK7,IJK8)
+C$OMP& PRIVATE(DJ1,DI1,RQ,RADLON,RADLON1,RADLON2,SLAT1,CLAT1)
+C$OMP& PRIVATE(PLN,PLNTOP,F,SLON,CLON,LR,LI)
+ DO J1=1,NPH
+ I1=J1
+ RADLON=(ORIENT-45)/DPR
+ J3=NPS+1-I1
+ I3=J1
+ J5=NPS+1-J1
+ I5=NPS+1-I1
+ J7=I1
+ I7=NPS+1-J1
+ IJ1=(I1-1)*NI+(J1-1)*NJ+1
+ IJ3=(I3-1)*NI+(J3-1)*NJ+1
+ IJ5=(I5-1)*NI+(J5-1)*NJ+1
+ IJ7=(I7-1)*NI+(J7-1)*NJ+1
+ DI1=I1-NPH-1
+ DJ1=J1-NPH-1
+ RQ=DI1**2+DJ1**2
+ SLAT1=(GQ-RQ)/(GQ+RQ)
+ CLAT1=SQRT(1.-SLAT1**2)
+ CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP,
+ & PLN,PLNTOP)
+ CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,KW,2*MXTOP,KMAX,
+ & CLAT1,PLN,PLNTOP,MP,WAVE,WTOP,F)
+ DO L=1,MAXWV
+ SLON(L,1)=SIN(L*RADLON)
+ CLON(L,1)=COS(L*RADLON)
+ SLON(L,3)=SLON(L,1)*CROT(MOD(1*L,4))
+ & -CLON(L,1)*SROT(MOD(1*L,4))
+ CLON(L,3)=CLON(L,1)*CROT(MOD(1*L,4))
+ & +SLON(L,1)*SROT(MOD(1*L,4))
+ SLON(L,5)=SLON(L,1)*CROT(MOD(2*L,4))
+ & -CLON(L,1)*SROT(MOD(2*L,4))
+ CLON(L,5)=CLON(L,1)*CROT(MOD(2*L,4))
+ & +SLON(L,1)*SROT(MOD(2*L,4))
+ SLON(L,7)=SLON(L,1)*CROT(MOD(3*L,4))
+ & -CLON(L,1)*SROT(MOD(3*L,4))
+ CLON(L,7)=CLON(L,1)*CROT(MOD(3*L,4))
+ & +SLON(L,1)*SROT(MOD(3*L,4))
+ ENDDO
+CDIR$ IVDEP
+ DO K=1,KMAX
+ IJK1=IJ1+(K-1)*KG
+ IJK3=IJ3+(K-1)*KG
+ IJK5=IJ5+(K-1)*KG
+ IJK7=IJ7+(K-1)*KG
+ GN(IJK1)=F(1,1,K)
+ GN(IJK3)=F(1,1,K)
+ GN(IJK5)=F(1,1,K)
+ GN(IJK7)=F(1,1,K)
+ GS(IJK1)=F(1,2,K)
+ GS(IJK3)=F(1,2,K)
+ GS(IJK5)=F(1,2,K)
+ GS(IJK7)=F(1,2,K)
+ ENDDO
+ IF(KMAX.EQ.1) THEN
+ DO L=1,MAXWV
+ LR=2*L+1
+ LI=2*L+2
+ GN(IJ1)=GN(IJ1)+2*(F(LR,1,1)*CLON(L,1)
+ & -F(LI,1,1)*SLON(L,1))
+ GN(IJ3)=GN(IJ3)+2*(F(LR,1,1)*CLON(L,3)
+ & -F(LI,1,1)*SLON(L,3))
+ GN(IJ5)=GN(IJ5)+2*(F(LR,1,1)*CLON(L,5)
+ & -F(LI,1,1)*SLON(L,5))
+ GN(IJ7)=GN(IJ7)+2*(F(LR,1,1)*CLON(L,7)
+ & -F(LI,1,1)*SLON(L,7))
+ GS(IJ1)=GS(IJ1)+2*(F(LR,2,1)*CLON(L,3)
+ & -F(LI,2,1)*SLON(L,3))
+ GS(IJ3)=GS(IJ3)+2*(F(LR,2,1)*CLON(L,1)
+ & -F(LI,2,1)*SLON(L,1))
+ GS(IJ5)=GS(IJ5)+2*(F(LR,2,1)*CLON(L,7)
+ & -F(LI,2,1)*SLON(L,7))
+ GS(IJ7)=GS(IJ7)+2*(F(LR,2,1)*CLON(L,5)
+ & -F(LI,2,1)*SLON(L,5))
+ ENDDO
+ ELSE
+ DO L=1,MAXWV
+ LR=2*L+1
+ LI=2*L+2
+CDIR$ IVDEP
+ DO K=1,KMAX
+ IJK1=IJ1+(K-1)*KG
+ IJK3=IJ3+(K-1)*KG
+ IJK5=IJ5+(K-1)*KG
+ IJK7=IJ7+(K-1)*KG
+ GN(IJK1)=GN(IJK1)+2*(F(LR,1,K)*CLON(L,1)
+ & -F(LI,1,K)*SLON(L,1))
+ GN(IJK3)=GN(IJK3)+2*(F(LR,1,K)*CLON(L,3)
+ & -F(LI,1,K)*SLON(L,3))
+ GN(IJK5)=GN(IJK5)+2*(F(LR,1,K)*CLON(L,5)
+ & -F(LI,1,K)*SLON(L,5))
+ GN(IJK7)=GN(IJK7)+2*(F(LR,1,K)*CLON(L,7)
+ & -F(LI,1,K)*SLON(L,7))
+ GS(IJK1)=GS(IJK1)+2*(F(LR,2,K)*CLON(L,3)
+ & -F(LI,2,K)*SLON(L,3))
+ GS(IJK3)=GS(IJK3)+2*(F(LR,2,K)*CLON(L,1)
+ & -F(LI,2,K)*SLON(L,1))
+ GS(IJK5)=GS(IJK5)+2*(F(LR,2,K)*CLON(L,7)
+ & -F(LI,2,K)*SLON(L,7))
+ GS(IJK7)=GS(IJK7)+2*(F(LR,2,K)*CLON(L,5)
+ & -F(LI,2,K)*SLON(L,5))
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDDO
+
+C CALCULATE THE REMAINDER OF THE POLAR STEREOGRAPHIC DOMAIN,
+C STARTING AT THE SECTOR JUST CLOCKWISE OF THE ORIENTATION LONGITUDE
+C AND GOING CLOCKWISE UNTIL ALL EIGHT SECTORS ARE DONE.
+C$OMP PARALLEL DO PRIVATE(I1,J2,I2,J3,I3,J4,I4,J5,I5,J6,I6,J7,I7,J8,I8)
+C$OMP& PRIVATE(IJ1,IJ2,IJ3,IJ4,IJ5,IJ6,IJ7,IJ8)
+C$OMP& PRIVATE(IJK1,IJK2,IJK3,IJK4,IJK5,IJK6,IJK7,IJK8)
+C$OMP& PRIVATE(DJ1,DI1,RQ,RADLON,RADLON1,RADLON2,SLAT1,CLAT1)
+C$OMP& PRIVATE(PLN,PLNTOP,F,SLON,CLON,LR,LI)
+ DO J1=1,NPH-1
+ DO I1=J1+1,NPH
+ J2=I1
+ I2=J1
+ J3=NPS+1-I1
+ I3=J1
+ J4=NPS+1-J1
+ I4=I1
+ J5=NPS+1-J1
+ I5=NPS+1-I1
+ J6=NPS+1-I1
+ I6=NPS+1-J1
+ J7=I1
+ I7=NPS+1-J1
+ J8=J1
+ I8=NPS+1-I1
+ IJ1=(I1-1)*NI+(J1-1)*NJ+1
+ IJ2=(I2-1)*NI+(J2-1)*NJ+1
+ IJ3=(I3-1)*NI+(J3-1)*NJ+1
+ IJ4=(I4-1)*NI+(J4-1)*NJ+1
+ IJ5=(I5-1)*NI+(J5-1)*NJ+1
+ IJ6=(I6-1)*NI+(J6-1)*NJ+1
+ IJ7=(I7-1)*NI+(J7-1)*NJ+1
+ IJ8=(I8-1)*NI+(J8-1)*NJ+1
+ DI1=I1-NPH-1
+ DJ1=J1-NPH-1
+ RQ=DI1**2+DJ1**2
+ SLAT1=(GQ-RQ)/(GQ+RQ)
+ CLAT1=SQRT(1.-SLAT1**2)
+ RADLON1=ORIENT/DPR+ATAN(-DI1/DJ1)
+ RADLON2=(ORIENT-45)/DPR*2-RADLON1
+ CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP,
+ & PLN,PLNTOP)
+ CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,KW,2*MXTOP,KMAX,
+ & CLAT1,PLN,PLNTOP,MP,WAVE,WTOP,F)
+ DO L=1,MAXWV
+ SLON(L,1)=SIN(L*RADLON1)
+ CLON(L,1)=COS(L*RADLON1)
+ SLON(L,2)=SIN(L*RADLON2)
+ CLON(L,2)=COS(L*RADLON2)
+ SLON(L,3)=SLON(L,1)*CROT(MOD(1*L,4))
+ & -CLON(L,1)*SROT(MOD(1*L,4))
+ CLON(L,3)=CLON(L,1)*CROT(MOD(1*L,4))
+ & +SLON(L,1)*SROT(MOD(1*L,4))
+ SLON(L,4)=SLON(L,2)*CROT(MOD(1*L,4))
+ & -CLON(L,2)*SROT(MOD(1*L,4))
+ CLON(L,4)=CLON(L,2)*CROT(MOD(1*L,4))
+ & +SLON(L,2)*SROT(MOD(1*L,4))
+ SLON(L,5)=SLON(L,1)*CROT(MOD(2*L,4))
+ & -CLON(L,1)*SROT(MOD(2*L,4))
+ CLON(L,5)=CLON(L,1)*CROT(MOD(2*L,4))
+ & +SLON(L,1)*SROT(MOD(2*L,4))
+ SLON(L,6)=SLON(L,2)*CROT(MOD(2*L,4))
+ & -CLON(L,2)*SROT(MOD(2*L,4))
+ CLON(L,6)=CLON(L,2)*CROT(MOD(2*L,4))
+ & +SLON(L,2)*SROT(MOD(2*L,4))
+ SLON(L,7)=SLON(L,1)*CROT(MOD(3*L,4))
+ & -CLON(L,1)*SROT(MOD(3*L,4))
+ CLON(L,7)=CLON(L,1)*CROT(MOD(3*L,4))
+ & +SLON(L,1)*SROT(MOD(3*L,4))
+ SLON(L,8)=SLON(L,2)*CROT(MOD(3*L,4))
+ & -CLON(L,2)*SROT(MOD(3*L,4))
+ CLON(L,8)=CLON(L,2)*CROT(MOD(3*L,4))
+ & +SLON(L,2)*SROT(MOD(3*L,4))
+ ENDDO
+CDIR$ IVDEP
+ DO K=1,KMAX
+ IJK1=IJ1+(K-1)*KG
+ IJK2=IJ2+(K-1)*KG
+ IJK3=IJ3+(K-1)*KG
+ IJK4=IJ4+(K-1)*KG
+ IJK5=IJ5+(K-1)*KG
+ IJK6=IJ6+(K-1)*KG
+ IJK7=IJ7+(K-1)*KG
+ IJK8=IJ8+(K-1)*KG
+ GN(IJK1)=F(1,1,K)
+ GN(IJK2)=F(1,1,K)
+ GN(IJK3)=F(1,1,K)
+ GN(IJK4)=F(1,1,K)
+ GN(IJK5)=F(1,1,K)
+ GN(IJK6)=F(1,1,K)
+ GN(IJK7)=F(1,1,K)
+ GN(IJK8)=F(1,1,K)
+ GS(IJK1)=F(1,2,K)
+ GS(IJK2)=F(1,2,K)
+ GS(IJK3)=F(1,2,K)
+ GS(IJK4)=F(1,2,K)
+ GS(IJK5)=F(1,2,K)
+ GS(IJK6)=F(1,2,K)
+ GS(IJK7)=F(1,2,K)
+ GS(IJK8)=F(1,2,K)
+ ENDDO
+ IF(KMAX.EQ.1) THEN
+ DO L=1,MAXWV
+ LR=2*L+1
+ LI=2*L+2
+ GN(IJ1)=GN(IJ1)+2*(F(LR,1,1)*CLON(L,1)
+ & -F(LI,1,1)*SLON(L,1))
+ GN(IJ2)=GN(IJ2)+2*(F(LR,1,1)*CLON(L,2)
+ & -F(LI,1,1)*SLON(L,2))
+ GN(IJ3)=GN(IJ3)+2*(F(LR,1,1)*CLON(L,3)
+ & -F(LI,1,1)*SLON(L,3))
+ GN(IJ4)=GN(IJ4)+2*(F(LR,1,1)*CLON(L,4)
+ & -F(LI,1,1)*SLON(L,4))
+ GN(IJ5)=GN(IJ5)+2*(F(LR,1,1)*CLON(L,5)
+ & -F(LI,1,1)*SLON(L,5))
+ GN(IJ6)=GN(IJ6)+2*(F(LR,1,1)*CLON(L,6)
+ & -F(LI,1,1)*SLON(L,6))
+ GN(IJ7)=GN(IJ7)+2*(F(LR,1,1)*CLON(L,7)
+ & -F(LI,1,1)*SLON(L,7))
+ GN(IJ8)=GN(IJ8)+2*(F(LR,1,1)*CLON(L,8)
+ & -F(LI,1,1)*SLON(L,8))
+ GS(IJ1)=GS(IJ1)+2*(F(LR,2,1)*CLON(L,4)
+ & -F(LI,2,1)*SLON(L,4))
+ GS(IJ2)=GS(IJ2)+2*(F(LR,2,1)*CLON(L,3)
+ & -F(LI,2,1)*SLON(L,3))
+ GS(IJ3)=GS(IJ3)+2*(F(LR,2,1)*CLON(L,2)
+ & -F(LI,2,1)*SLON(L,2))
+ GS(IJ4)=GS(IJ4)+2*(F(LR,2,1)*CLON(L,1)
+ & -F(LI,2,1)*SLON(L,1))
+ GS(IJ5)=GS(IJ5)+2*(F(LR,2,1)*CLON(L,8)
+ & -F(LI,2,1)*SLON(L,8))
+ GS(IJ6)=GS(IJ6)+2*(F(LR,2,1)*CLON(L,7)
+ & -F(LI,2,1)*SLON(L,7))
+ GS(IJ7)=GS(IJ7)+2*(F(LR,2,1)*CLON(L,6)
+ & -F(LI,2,1)*SLON(L,6))
+ GS(IJ8)=GS(IJ8)+2*(F(LR,2,1)*CLON(L,5)
+ & -F(LI,2,1)*SLON(L,5))
+ ENDDO
+ ELSE
+ DO L=1,MAXWV
+ LR=2*L+1
+ LI=2*L+2
+CDIR$ IVDEP
+ DO K=1,KMAX
+ IJK1=IJ1+(K-1)*KG
+ IJK2=IJ2+(K-1)*KG
+ IJK3=IJ3+(K-1)*KG
+ IJK4=IJ4+(K-1)*KG
+ IJK5=IJ5+(K-1)*KG
+ IJK6=IJ6+(K-1)*KG
+ IJK7=IJ7+(K-1)*KG
+ IJK8=IJ8+(K-1)*KG
+ GN(IJK1)=GN(IJK1)+2*(F(LR,1,K)*CLON(L,1)
+ & -F(LI,1,K)*SLON(L,1))
+ GN(IJK2)=GN(IJK2)+2*(F(LR,1,K)*CLON(L,2)
+ & -F(LI,1,K)*SLON(L,2))
+ GN(IJK3)=GN(IJK3)+2*(F(LR,1,K)*CLON(L,3)
+ & -F(LI,1,K)*SLON(L,3))
+ GN(IJK4)=GN(IJK4)+2*(F(LR,1,K)*CLON(L,4)
+ & -F(LI,1,K)*SLON(L,4))
+ GN(IJK5)=GN(IJK5)+2*(F(LR,1,K)*CLON(L,5)
+ & -F(LI,1,K)*SLON(L,5))
+ GN(IJK6)=GN(IJK6)+2*(F(LR,1,K)*CLON(L,6)
+ & -F(LI,1,K)*SLON(L,6))
+ GN(IJK7)=GN(IJK7)+2*(F(LR,1,K)*CLON(L,7)
+ & -F(LI,1,K)*SLON(L,7))
+ GN(IJK8)=GN(IJK8)+2*(F(LR,1,K)*CLON(L,8)
+ & -F(LI,1,K)*SLON(L,8))
+ GS(IJK1)=GS(IJK1)+2*(F(LR,2,K)*CLON(L,4)
+ & -F(LI,2,K)*SLON(L,4))
+ GS(IJK2)=GS(IJK2)+2*(F(LR,2,K)*CLON(L,3)
+ & -F(LI,2,K)*SLON(L,3))
+ GS(IJK3)=GS(IJK3)+2*(F(LR,2,K)*CLON(L,2)
+ & -F(LI,2,K)*SLON(L,2))
+ GS(IJK4)=GS(IJK4)+2*(F(LR,2,K)*CLON(L,1)
+ & -F(LI,2,K)*SLON(L,1))
+ GS(IJK5)=GS(IJK5)+2*(F(LR,2,K)*CLON(L,8)
+ & -F(LI,2,K)*SLON(L,8))
+ GS(IJK6)=GS(IJK6)+2*(F(LR,2,K)*CLON(L,7)
+ & -F(LI,2,K)*SLON(L,7))
+ GS(IJK7)=GS(IJK7)+2*(F(LR,2,K)*CLON(L,6)
+ & -F(LI,2,K)*SLON(L,6))
+ GS(IJK8)=GS(IJK8)+2*(F(LR,2,K)*CLON(L,5)
+ & -F(LI,2,K)*SLON(L,5))
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDDO
+ ENDDO
+
+ END
diff --git a/src/sptgpsd.f b/src/sptgpsd.f
new file mode 100644
index 00000000..69cc3c34
--- /dev/null
+++ b/src/sptgpsd.f
@@ -0,0 +1,100 @@
+C> @file
+C> @brief Transform spectral to polar stereographic gradients
+C> ### Program history log:
+C> Date | Programmer | Comments
+C> -----|------------|----------
+C> 96-02-29 | IREDELL | Initial.
+C> 1998-12-15 | IREDELL | OpenMP directives inserted.
+C> @author IREDELL @date 96-02-29
+
+C> This subprogram performs a spherical transform
+C> from spectral coefficients of scalar fields
+C> to gradient fields on a pair of polar stereographic grids.
+C> The wave-space can be either triangular or rhomboidal.
+C> The wave and grid fields may have general indexing,
+C> but each wave field is in sequential 'ibm order',
+C> i.e., with zonal wavenumber as the slower index.
+C> The two square polar stereographic grids are centered
+C> on the respective poles, with the orientation longitude
+C> of the southern hemisphere grid 180 degrees opposite
+C> that of the northern hemisphere grid.
+C> The vectors are automatically rotated to be resolved
+C> relative to the respective polar stereographic grids.
+C>
+C> The transform is made efficient by combining points in eight
+C> sectors of each polar stereographic grid, numbered as in the
+C> following diagram. The pole and the sector boundaries are
+C> treated specially in the code. Unfortunately, this approach
+C> induces some hairy indexing and code loquacity, for which
+C> the developer apologizes.
+C>
+C> \verbatim
+C> \ 4 | 5 /
+C> \ | /
+C> 3 \ | / 6
+C> \|/
+C> ----+----
+C> /|\
+C> 2 / | \ 7
+C> / | \
+C> / 1 | 8 \
+C> \endverbatim
+C>
+C> The transforms are all multiprocessed over sector points.
+C> transform several fields at a time to improve vectorization.
+C> Subprogram can be called from a multiprocessing environment.
+C>
+C> @param IROMB Spectral domain shape
+C> (0 for triangular, 1 for rhomboidal)
+C> @param MAXWV Spectral truncation
+C> @param KMAX Number of fields to transform
+C> @param NPS Odd order of the polar stereographic grids
+C> @param KWSKIP Skip number between wave fields
+C> (defaults to (MAXWV+1)*((IROMB+1)*MAXWV+2) if KWSKIP=0)
+C> @param KGSKIP Skip number between grid fields
+C> (defaults to NPS*NPS if KGSKIP=0)
+C> @param NISKIP Skip number between grid i-points
+C> (defaults to 1 if NISKIP=0)
+C> @param NJSKIP Skip number between grid j-points
+C> (defaults to NPS if NJSKIP=0)
+C> @param TRUE Latitude at which PS grid is true (usually 60.)
+C> @param XMESH Grid length at true latitude (M)
+C> @param ORIENT Longitude at bottom of northern PS grid
+C> (southern PS grid will have opposite orientation.)
+C> @param WAVE Wave fields
+C> @param XN Northern polar stereographic x-gradients
+C> @param YN Northern polar stereographic y-gradients
+C> @param XS Southern polar stereographic x-gradients
+C> @param YS Southern polar stereographic y-gradients
+C>
+C> @author IREDELL @date 96-02-29
+ SUBROUTINE SPTGPSD(IROMB,MAXWV,KMAX,NPS,
+ & KWSKIP,KGSKIP,NISKIP,NJSKIP,
+ & TRUE,XMESH,ORIENT,WAVE,XN,YN,XS,YS)
+
+ REAL WAVE(*),XN(*),YN(*),XS(*),YS(*)
+ REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1)
+ REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1)
+ REAL WD((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX)
+ REAL WZ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C CALCULATE PRELIMINARY CONSTANTS
+ CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP)
+ MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+ MDIM=2*MX+1
+ KW=KWSKIP
+ IF(KW.EQ.0) KW=2*MX
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C CALCULATE GRADIENTS
+C$OMP PARALLEL DO PRIVATE(KWS)
+ DO K=1,KMAX
+ KWS=(K-1)*KW
+ CALL SPLAPLAC(IROMB,MAXWV,ENN1,WAVE(KWS+1),WD(1,K),1)
+ WZ(1:2*MX,K)=0.
+ ENDDO
+ CALL SPTGPSV(IROMB,MAXWV,KMAX,NPS,MDIM,KGSKIP,NISKIP,NJSKIP,
+ & TRUE,XMESH,ORIENT,WD,WZ,XN,YN,XS,YS)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ END
diff --git a/src/sptgpsv.f b/src/sptgpsv.f
new file mode 100644
index 00000000..edb58fdd
--- /dev/null
+++ b/src/sptgpsv.f
@@ -0,0 +1,934 @@
+C> @file
+C> @brief Transform spectral vector to polar stereo.
+C>
+C> ### Program History Log
+C> Date | Programmer | Comments
+C> -----|------------|---------
+C> 96-02-29 | Iredell | Initial.
+C> 1998-12-15 | Iredell | Openmp directives inserted.
+C>
+C> @author Iredell @date 96-02-29
+
+C> This subprogram performs a spherical transform
+C> from spectral coefficients of divergences and curls
+C> to vector fields on a pair of polar stereographic grids.
+C> The wave-space can be either triangular or rhomboidal.
+C>
+C> The wave and grid fields may have general indexing,
+C> but each wave field is in sequential 'IBM order',
+C> i.e. with zonal wavenumber as the slower index.
+C>
+C> The two square polar stereographic grids are centered
+C> on the respective poles, with the orientation longitude
+C> of the southern hemisphere grid 180 degrees opposite
+C> that of the northern hemisphere grid.
+C>
+C> The vectors are automatically rotated to be resolved
+C> relative to the respective polar stereographic grids.
+C>
+C> The transform is made efficient
+C> by combining points in eight sectors
+C> of each polar stereographic grid,
+C> numbered as in the diagram below.
+C> The pole and the sector boundaries
+C> are treated specially in the code.
+C> Unfortunately, this approach induces
+C> some hairy indexing and code loquacity,
+C> for which the developer apologizes.
+C>
+C>
+C> \ 4 | 5 /
+C> \ | /
+C> 3 \ | / 6
+C> \|/
+C> ----+----
+C> /|\
+C> 2 / | \ 7
+C> / | \
+C> / 1 | 8 \
+C>
+C>
+C> The transforms are all multiprocessed over sector points.
+C> transform several fields at a time to improve vectorization.
+C> subprogram can be called from a multiprocessing environment.
+C>
+C> @param IROMB spectral domain shape
+C> (0 for triangular, 1 for rhomboidal)
+C> @param MAXWV spectral truncation
+C> @param KMAX number of fields to transform.
+C> @param NPS odd order of the polar stereographic grids
+C> @param KWSKIP skip number between wave fields
+C> (defaults to (MAXWV+1)*((IROMB+1)*MAXWV+2) if KWSKIP=0)
+C> @param KGSKIP skip number between grid fields
+C> (defaults to NPS*NPS if KGSKIP=0)
+C> @param NISKIP skip number between grid i-points
+C> (defaults to 1 if NISKIP=0)
+C> @param NJSKIP skip number between grid j-points
+C> (defaults to NPS if NJSKIP=0)
+C> @param TRUE latitude at which ps grid is true (usually 60.)
+C> @param XMESH grid length at true latitude (m)
+C> @param ORIENT longitude at bottom of northern ps grid
+C> (southern ps grid will have opposite orientation.)
+C> @param WAVED wave divergence fields
+C> @param WAVEZ wave vorticity fields
+C> @param UN northern polar stereographic u-winds
+C> @param VN northern polar stereographic v-winds
+C> @param US southern polar stereographic u-winds
+C> @param VS southern polar stereographic v-winds
+C>
+C> @author Iredell @date 96-02-29
+ SUBROUTINE SPTGPSV(IROMB,MAXWV,KMAX,NPS,
+ & KWSKIP,KGSKIP,NISKIP,NJSKIP,
+ & TRUE,XMESH,ORIENT,WAVED,WAVEZ,UN,VN,US,VS)
+
+ REAL WAVED(*),WAVEZ(*),UN(*),VN(*),US(*),VS(*)
+ REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1)
+ REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1)
+ INTEGER MP(2*KMAX)
+ REAL SLON(MAXWV,8),CLON(MAXWV,8),SROT(0:3),CROT(0:3)
+ REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,2*KMAX)
+ REAL WTOP(2*(MAXWV+1),2*KMAX)
+ REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),PLNTOP(MAXWV+1)
+ REAL F(2*MAXWV+3,2,2*KMAX)
+ DATA SROT/0.,1.,0.,-1./,CROT/1.,0.,-1.,0./
+ PARAMETER(RERTH=6.3712E6)
+ PARAMETER(PI=3.14159265358979,DPR=180./PI)
+
+C CALCULATE PRELIMINARY CONSTANTS
+ CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP)
+ MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+ MXTOP=MAXWV+1
+ MDIM=2*MX+1
+ IDIM=2*MAXWV+3
+ KW=KWSKIP
+ KG=KGSKIP
+ NI=NISKIP
+ NJ=NJSKIP
+ IF(KW.EQ.0) KW=2*MX
+ IF(KG.EQ.0) KG=NPS*NPS
+ IF(NI.EQ.0) NI=1
+ IF(NJ.EQ.0) NJ=NPS
+ MP=1
+ NPH=(NPS-1)/2
+ GQ=((1.+SIN(TRUE/DPR))*RERTH/XMESH)**2
+ SRH=SQRT(0.5)
+
+C CALCULATE SPECTRAL WINDS
+C$OMP PARALLEL DO PRIVATE(KWS)
+ DO K=1,KMAX
+ KWS=(K-1)*KW
+ CALL SPDZ2UV(IROMB,MAXWV,ENN1,ELONN1,EON,EONTOP,
+ & WAVED(KWS+1),WAVEZ(KWS+1),
+ & W(1,K),W(1,KMAX+K),WTOP(1,K),WTOP(1,KMAX+K))
+ ENDDO
+
+C CALCULATE POLE POINT
+ I1=NPH+1
+ J1=NPH+1
+ IJ1=(I1-1)*NI+(J1-1)*NJ+1
+ SLAT1=1.
+ CLAT1=0.
+ CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP,
+ & PLN,PLNTOP)
+ CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,MDIM,2*MXTOP,2*KMAX,
+ & CLAT1,PLN,PLNTOP,MP,W,WTOP,F)
+ COSO=COS(ORIENT/DPR)
+ SINO=SIN(ORIENT/DPR)
+CDIR$ IVDEP
+ DO K=1,KMAX
+ KU=K
+ KV=K+KMAX
+ IJK1=IJ1+(K-1)*KG
+ UN(IJK1)=2*( COSO*F(3,1,KU)+SINO*F(3,1,KV))
+ VN(IJK1)=2*(-SINO*F(3,1,KU)+COSO*F(3,1,KV))
+ US(IJK1)=2*( COSO*F(3,2,KU)-SINO*F(3,2,KV))
+ VS(IJK1)=2*( SINO*F(3,2,KU)+COSO*F(3,2,KV))
+ ENDDO
+
+C CALCULATE POINTS ALONG THE ROW AND COLUMN OF THE POLE,
+C STARTING AT THE ORIENTATION LONGITUDE AND GOING CLOCKWISE.
+C$OMP PARALLEL DO PRIVATE(I1,J2,I2,J3,I3,J4,I4,J5,I5,J6,I6,J7,I7,J8,I8)
+C$OMP& PRIVATE(IJ1,IJ2,IJ3,IJ4,IJ5,IJ6,IJ7,IJ8)
+C$OMP& PRIVATE(IJK1,IJK2,IJK3,IJK4,IJK5,IJK6,IJK7,IJK8)
+C$OMP& PRIVATE(DJ1,DI1,RQ,RR,RADLON,RADLON1,RADLON2,SLAT1,CLAT1)
+C$OMP& PRIVATE(PLN,PLNTOP,F,SLON,CLON,KU,KV,LR,LI)
+ DO J1=1,NPH
+ I1=NPH+1
+ RADLON=ORIENT/DPR
+ J3=NPS+1-I1
+ I3=J1
+ J5=NPS+1-J1
+ I5=NPS+1-I1
+ J7=I1
+ I7=NPS+1-J1
+ IJ1=(I1-1)*NI+(J1-1)*NJ+1
+ IJ3=(I3-1)*NI+(J3-1)*NJ+1
+ IJ5=(I5-1)*NI+(J5-1)*NJ+1
+ IJ7=(I7-1)*NI+(J7-1)*NJ+1
+ DI1=I1-NPH-1
+ DJ1=J1-NPH-1
+ RQ=DI1**2+DJ1**2
+ SLAT1=(GQ-RQ)/(GQ+RQ)
+ CLAT1=SQRT(1.-SLAT1**2)
+ CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP,
+ & PLN,PLNTOP)
+ CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,MDIM,2*MXTOP,2*KMAX,
+ & CLAT1,PLN,PLNTOP,MP,W,WTOP,F)
+ DO L=1,MAXWV
+ SLON(L,1)=SIN(L*RADLON)
+ CLON(L,1)=COS(L*RADLON)
+ SLON(L,3)=SLON(L,1)*CROT(MOD(1*L,4))
+ & -CLON(L,1)*SROT(MOD(1*L,4))
+ CLON(L,3)=CLON(L,1)*CROT(MOD(1*L,4))
+ & +SLON(L,1)*SROT(MOD(1*L,4))
+ SLON(L,5)=SLON(L,1)*CROT(MOD(2*L,4))
+ & -CLON(L,1)*SROT(MOD(2*L,4))
+ CLON(L,5)=CLON(L,1)*CROT(MOD(2*L,4))
+ & +SLON(L,1)*SROT(MOD(2*L,4))
+ SLON(L,7)=SLON(L,1)*CROT(MOD(3*L,4))
+ & -CLON(L,1)*SROT(MOD(3*L,4))
+ CLON(L,7)=CLON(L,1)*CROT(MOD(3*L,4))
+ & +SLON(L,1)*SROT(MOD(3*L,4))
+ ENDDO
+CDIR$ IVDEP
+ DO K=1,KMAX
+ KU=K
+ KV=K+KMAX
+ IJK1=IJ1+(K-1)*KG
+ IJK3=IJ3+(K-1)*KG
+ IJK5=IJ5+(K-1)*KG
+ IJK7=IJ7+(K-1)*KG
+ UN(IJK1)= F(1,1,KU)
+ VN(IJK1)= F(1,1,KV)
+ UN(IJK3)= F(1,1,KV)
+ VN(IJK3)=-F(1,1,KU)
+ UN(IJK5)=-F(1,1,KU)
+ VN(IJK5)=-F(1,1,KV)
+ UN(IJK7)=-F(1,1,KV)
+ VN(IJK7)= F(1,1,KU)
+ US(IJK1)=-F(1,2,KU)
+ VS(IJK1)=-F(1,2,KV)
+ US(IJK3)=-F(1,2,KV)
+ VS(IJK3)= F(1,2,KU)
+ US(IJK5)= F(1,2,KU)
+ VS(IJK5)= F(1,2,KV)
+ US(IJK7)= F(1,2,KV)
+ VS(IJK7)=-F(1,2,KU)
+ ENDDO
+ IF(KMAX.EQ.1) THEN
+ KU=1
+ KV=2
+ DO L=1,MAXWV
+ LR=2*L+1
+ LI=2*L+2
+ UN(IJ1)=UN(IJ1)+2*(F(LR,1,KU)*CLON(L,1)
+ & -F(LI,1,KU)*SLON(L,1))
+ VN(IJ1)=VN(IJ1)+2*(F(LR,1,KV)*CLON(L,1)
+ & -F(LI,1,KV)*SLON(L,1))
+ UN(IJ3)=UN(IJ3)+2*(F(LR,1,KV)*CLON(L,3)
+ & -F(LI,1,KV)*SLON(L,3))
+ VN(IJ3)=VN(IJ3)-2*(F(LR,1,KU)*CLON(L,3)
+ & -F(LI,1,KU)*SLON(L,3))
+ UN(IJ5)=UN(IJ5)-2*(F(LR,1,KU)*CLON(L,5)
+ & -F(LI,1,KU)*SLON(L,5))
+ VN(IJ5)=VN(IJ5)-2*(F(LR,1,KV)*CLON(L,5)
+ & -F(LI,1,KV)*SLON(L,5))
+ UN(IJ7)=UN(IJ7)-2*(F(LR,1,KV)*CLON(L,7)
+ & -F(LI,1,KV)*SLON(L,7))
+ VN(IJ7)=VN(IJ7)+2*(F(LR,1,KU)*CLON(L,7)
+ & -F(LI,1,KU)*SLON(L,7))
+ US(IJ1)=US(IJ1)-2*(F(LR,2,KU)*CLON(L,5)
+ & -F(LI,2,KU)*SLON(L,5))
+ VS(IJ1)=VS(IJ1)-2*(F(LR,2,KV)*CLON(L,5)
+ & -F(LI,2,KV)*SLON(L,5))
+ US(IJ3)=US(IJ3)-2*(F(LR,2,KV)*CLON(L,3)
+ & -F(LI,2,KV)*SLON(L,3))
+ VS(IJ3)=VS(IJ3)+2*(F(LR,2,KU)*CLON(L,3)
+ & -F(LI,2,KU)*SLON(L,3))
+ US(IJ5)=US(IJ5)+2*(F(LR,2,KU)*CLON(L,1)
+ & -F(LI,2,KU)*SLON(L,1))
+ VS(IJ5)=VS(IJ5)+2*(F(LR,2,KV)*CLON(L,1)
+ & -F(LI,2,KV)*SLON(L,1))
+ US(IJ7)=US(IJ7)+2*(F(LR,2,KV)*CLON(L,7)
+ & -F(LI,2,KV)*SLON(L,7))
+ VS(IJ7)=VS(IJ7)-2*(F(LR,2,KU)*CLON(L,7)
+ & -F(LI,2,KU)*SLON(L,7))
+ ENDDO
+ ELSE
+ DO L=1,MAXWV
+ LR=2*L+1
+ LI=2*L+2
+CDIR$ IVDEP
+ DO K=1,KMAX
+ KU=K
+ KV=K+KMAX
+ IJK1=IJ1+(K-1)*KG
+ IJK3=IJ3+(K-1)*KG
+ IJK5=IJ5+(K-1)*KG
+ IJK7=IJ7+(K-1)*KG
+ UN(IJK1)=UN(IJK1)+2*(F(LR,1,KU)*CLON(L,1)
+ & -F(LI,1,KU)*SLON(L,1))
+ VN(IJK1)=VN(IJK1)+2*(F(LR,1,KV)*CLON(L,1)
+ & -F(LI,1,KV)*SLON(L,1))
+ UN(IJK3)=UN(IJK3)+2*(F(LR,1,KV)*CLON(L,3)
+ & -F(LI,1,KV)*SLON(L,3))
+ VN(IJK3)=VN(IJK3)-2*(F(LR,1,KU)*CLON(L,3)
+ & -F(LI,1,KU)*SLON(L,3))
+ UN(IJK5)=UN(IJK5)-2*(F(LR,1,KU)*CLON(L,5)
+ & -F(LI,1,KU)*SLON(L,5))
+ VN(IJK5)=VN(IJK5)-2*(F(LR,1,KV)*CLON(L,5)
+ & -F(LI,1,KV)*SLON(L,5))
+ UN(IJK7)=UN(IJK7)-2*(F(LR,1,KV)*CLON(L,7)
+ & -F(LI,1,KV)*SLON(L,7))
+ VN(IJK7)=VN(IJK7)+2*(F(LR,1,KU)*CLON(L,7)
+ & -F(LI,1,KU)*SLON(L,7))
+ US(IJK1)=US(IJK1)-2*(F(LR,2,KU)*CLON(L,5)
+ & -F(LI,2,KU)*SLON(L,5))
+ VS(IJK1)=VS(IJK1)-2*(F(LR,2,KV)*CLON(L,5)
+ & -F(LI,2,KV)*SLON(L,5))
+ US(IJK3)=US(IJK3)-2*(F(LR,2,KV)*CLON(L,3)
+ & -F(LI,2,KV)*SLON(L,3))
+ VS(IJK3)=VS(IJK3)+2*(F(LR,2,KU)*CLON(L,3)
+ & -F(LI,2,KU)*SLON(L,3))
+ US(IJK5)=US(IJK5)+2*(F(LR,2,KU)*CLON(L,1)
+ & -F(LI,2,KU)*SLON(L,1))
+ VS(IJK5)=VS(IJK5)+2*(F(LR,2,KV)*CLON(L,1)
+ & -F(LI,2,KV)*SLON(L,1))
+ US(IJK7)=US(IJK7)+2*(F(LR,2,KV)*CLON(L,7)
+ & -F(LI,2,KV)*SLON(L,7))
+ VS(IJK7)=VS(IJK7)-2*(F(LR,2,KU)*CLON(L,7)
+ & -F(LI,2,KU)*SLON(L,7))
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDDO
+
+C CALCULATE POINTS ON THE MAIN DIAGONALS THROUGH THE POLE,
+C STARTING CLOCKWISE OF THE ORIENTATION LONGITUDE AND GOING CLOCKWISE.
+C$OMP PARALLEL DO PRIVATE(I1,J2,I2,J3,I3,J4,I4,J5,I5,J6,I6,J7,I7,J8,I8)
+C$OMP& PRIVATE(IJ1,IJ2,IJ3,IJ4,IJ5,IJ6,IJ7,IJ8)
+C$OMP& PRIVATE(IJK1,IJK2,IJK3,IJK4,IJK5,IJK6,IJK7,IJK8)
+C$OMP& PRIVATE(DJ1,DI1,RQ,RR,RADLON,RADLON1,RADLON2,SLAT1,CLAT1)
+C$OMP& PRIVATE(PLN,PLNTOP,F,SLON,CLON,KU,KV,LR,LI)
+ DO J1=1,NPH
+ I1=J1
+ RADLON=(ORIENT-45)/DPR
+ J3=NPS+1-I1
+ I3=J1
+ J5=NPS+1-J1
+ I5=NPS+1-I1
+ J7=I1
+ I7=NPS+1-J1
+ IJ1=(I1-1)*NI+(J1-1)*NJ+1
+ IJ3=(I3-1)*NI+(J3-1)*NJ+1
+ IJ5=(I5-1)*NI+(J5-1)*NJ+1
+ IJ7=(I7-1)*NI+(J7-1)*NJ+1
+ DI1=I1-NPH-1
+ DJ1=J1-NPH-1
+ RQ=DI1**2+DJ1**2
+ SLAT1=(GQ-RQ)/(GQ+RQ)
+ CLAT1=SQRT(1.-SLAT1**2)
+ CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP,
+ & PLN,PLNTOP)
+ CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,MDIM,2*MXTOP,2*KMAX,
+ & CLAT1,PLN,PLNTOP,MP,W,WTOP,F)
+ DO L=1,MAXWV
+ SLON(L,1)=SIN(L*RADLON)
+ CLON(L,1)=COS(L*RADLON)
+ SLON(L,3)=SLON(L,1)*CROT(MOD(1*L,4))
+ & -CLON(L,1)*SROT(MOD(1*L,4))
+ CLON(L,3)=CLON(L,1)*CROT(MOD(1*L,4))
+ & +SLON(L,1)*SROT(MOD(1*L,4))
+ SLON(L,5)=SLON(L,1)*CROT(MOD(2*L,4))
+ & -CLON(L,1)*SROT(MOD(2*L,4))
+ CLON(L,5)=CLON(L,1)*CROT(MOD(2*L,4))
+ & +SLON(L,1)*SROT(MOD(2*L,4))
+ SLON(L,7)=SLON(L,1)*CROT(MOD(3*L,4))
+ & -CLON(L,1)*SROT(MOD(3*L,4))
+ CLON(L,7)=CLON(L,1)*CROT(MOD(3*L,4))
+ & +SLON(L,1)*SROT(MOD(3*L,4))
+ ENDDO
+CDIR$ IVDEP
+ DO K=1,KMAX
+ KU=K
+ KV=K+KMAX
+ IJK1=IJ1+(K-1)*KG
+ IJK3=IJ3+(K-1)*KG
+ IJK5=IJ5+(K-1)*KG
+ IJK7=IJ7+(K-1)*KG
+ UN(IJK1)=SRH*( F(1,1,KU)+F(1,1,KV))
+ VN(IJK1)=SRH*(-F(1,1,KU)+F(1,1,KV))
+ UN(IJK3)=SRH*(-F(1,1,KU)+F(1,1,KV))
+ VN(IJK3)=SRH*(-F(1,1,KU)-F(1,1,KV))
+ UN(IJK5)=SRH*(-F(1,1,KU)-F(1,1,KV))
+ VN(IJK5)=SRH*( F(1,1,KU)-F(1,1,KV))
+ UN(IJK7)=SRH*( F(1,1,KU)-F(1,1,KV))
+ VN(IJK7)=SRH*( F(1,1,KU)+F(1,1,KV))
+ US(IJK1)=SRH*(-F(1,2,KU)-F(1,2,KV))
+ VS(IJK1)=SRH*( F(1,2,KU)-F(1,2,KV))
+ US(IJK3)=SRH*( F(1,2,KU)-F(1,2,KV))
+ VS(IJK3)=SRH*( F(1,2,KU)+F(1,2,KV))
+ US(IJK5)=SRH*( F(1,2,KU)+F(1,2,KV))
+ VS(IJK5)=SRH*(-F(1,2,KU)+F(1,2,KV))
+ US(IJK7)=SRH*(-F(1,2,KU)+F(1,2,KV))
+ VS(IJK7)=SRH*(-F(1,2,KU)-F(1,2,KV))
+ ENDDO
+ IF(KMAX.EQ.1) THEN
+ KU=1
+ KV=2
+ DO L=1,MAXWV
+ LR=2*L+1
+ LI=2*L+2
+ UN(IJ1)=UN(IJ1)+2*SRH*(( F(LR,1,KU)+F(LR,1,KV))
+ & *CLON(L,1)
+ & -( F(LI,1,KU)+F(LI,1,KV))
+ & *SLON(L,1))
+ VN(IJ1)=VN(IJ1)+2*SRH*((-F(LR,1,KU)+F(LR,1,KV))
+ & *CLON(L,1)
+ & -(-F(LI,1,KU)+F(LI,1,KV))
+ & *SLON(L,1))
+ UN(IJ3)=UN(IJ3)+2*SRH*((-F(LR,1,KU)+F(LR,1,KV))
+ & *CLON(L,3)
+ & -(-F(LI,1,KU)+F(LI,1,KV))
+ & *SLON(L,3))
+ VN(IJ3)=VN(IJ3)+2*SRH*((-F(LR,1,KU)-F(LR,1,KV))
+ & *CLON(L,3)
+ & -(-F(LI,1,KU)-F(LI,1,KV))
+ & *SLON(L,3))
+ UN(IJ5)=UN(IJ5)+2*SRH*((-F(LR,1,KU)-F(LR,1,KV))
+ & *CLON(L,5)
+ & -(-F(LI,1,KU)-F(LI,1,KV))
+ & *SLON(L,5))
+ VN(IJ5)=VN(IJ5)+2*SRH*(( F(LR,1,KU)-F(LR,1,KV))
+ & *CLON(L,5)
+ & -( F(LI,1,KU)-F(LI,1,KV))
+ & *SLON(L,5))
+ UN(IJ7)=UN(IJ7)+2*SRH*(( F(LR,1,KU)-F(LR,1,KV))
+ & *CLON(L,7)
+ & -( F(LI,1,KU)-F(LI,1,KV))
+ & *SLON(L,7))
+ VN(IJ7)=VN(IJ7)+2*SRH*(( F(LR,1,KU)+F(LR,1,KV))
+ & *CLON(L,7)
+ & -( F(LI,1,KU)+F(LI,1,KV))
+ & *SLON(L,7))
+ US(IJ1)=US(IJ1)+2*SRH*((-F(LR,2,KU)-F(LR,2,KV))
+ & *CLON(L,3)
+ & -(-F(LI,2,KU)-F(LI,2,KV))
+ & *SLON(L,3))
+ VS(IJ1)=VS(IJ1)+2*SRH*(( F(LR,2,KU)-F(LR,2,KV))
+ & *CLON(L,3)
+ & -( F(LI,2,KU)-F(LI,2,KV))
+ & *SLON(L,3))
+ US(IJ3)=US(IJ3)+2*SRH*(( F(LR,2,KU)-F(LR,2,KV))
+ & *CLON(L,1)
+ & -( F(LI,2,KU)-F(LI,2,KV))
+ & *SLON(L,1))
+ VS(IJ3)=VS(IJ3)+2*SRH*(( F(LR,2,KU)+F(LR,2,KV))
+ & *CLON(L,1)
+ & -( F(LI,2,KU)+F(LI,2,KV))
+ & *SLON(L,1))
+ US(IJ5)=US(IJ5)+2*SRH*(( F(LR,2,KU)+F(LR,2,KV))
+ & *CLON(L,7)
+ & -( F(LI,2,KU)+F(LI,2,KV))
+ & *SLON(L,7))
+ VS(IJ5)=VS(IJ5)+2*SRH*((-F(LR,2,KU)+F(LR,2,KV))
+ & *CLON(L,7)
+ & -(-F(LI,2,KU)+F(LI,2,KV))
+ & *SLON(L,7))
+ US(IJ7)=US(IJ7)+2*SRH*((-F(LR,2,KU)+F(LR,2,KV))
+ & *CLON(L,5)
+ & -(-F(LI,2,KU)+F(LI,2,KV))
+ & *SLON(L,5))
+ VS(IJ7)=VS(IJ7)+2*SRH*((-F(LR,2,KU)-F(LR,2,KV))
+ & *CLON(L,5)
+ & -(-F(LI,2,KU)-F(LI,2,KV))
+ & *SLON(L,5))
+ ENDDO
+ ELSE
+ DO L=1,MAXWV
+ LR=2*L+1
+ LI=2*L+2
+CDIR$ IVDEP
+ DO K=1,KMAX
+ KU=K
+ KV=K+KMAX
+ IJK1=IJ1+(K-1)*KG
+ IJK3=IJ3+(K-1)*KG
+ IJK5=IJ5+(K-1)*KG
+ IJK7=IJ7+(K-1)*KG
+ UN(IJK1)=UN(IJK1)+2*SRH*(( F(LR,1,KU)+F(LR,1,KV))
+ & *CLON(L,1)
+ & -( F(LI,1,KU)+F(LI,1,KV))
+ & *SLON(L,1))
+ VN(IJK1)=VN(IJK1)+2*SRH*((-F(LR,1,KU)+F(LR,1,KV))
+ & *CLON(L,1)
+ & -(-F(LI,1,KU)+F(LI,1,KV))
+ & *SLON(L,1))
+ UN(IJK3)=UN(IJK3)+2*SRH*((-F(LR,1,KU)+F(LR,1,KV))
+ & *CLON(L,3)
+ & -(-F(LI,1,KU)+F(LI,1,KV))
+ & *SLON(L,3))
+ VN(IJK3)=VN(IJK3)+2*SRH*((-F(LR,1,KU)-F(LR,1,KV))
+ & *CLON(L,3)
+ & -(-F(LI,1,KU)-F(LI,1,KV))
+ & *SLON(L,3))
+ UN(IJK5)=UN(IJK5)+2*SRH*((-F(LR,1,KU)-F(LR,1,KV))
+ & *CLON(L,5)
+ & -(-F(LI,1,KU)-F(LI,1,KV))
+ & *SLON(L,5))
+ VN(IJK5)=VN(IJK5)+2*SRH*(( F(LR,1,KU)-F(LR,1,KV))
+ & *CLON(L,5)
+ & -( F(LI,1,KU)-F(LI,1,KV))
+ & *SLON(L,5))
+ UN(IJK7)=UN(IJK7)+2*SRH*(( F(LR,1,KU)-F(LR,1,KV))
+ & *CLON(L,7)
+ & -( F(LI,1,KU)-F(LI,1,KV))
+ & *SLON(L,7))
+ VN(IJK7)=VN(IJK7)+2*SRH*(( F(LR,1,KU)+F(LR,1,KV))
+ & *CLON(L,7)
+ & -( F(LI,1,KU)+F(LI,1,KV))
+ & *SLON(L,7))
+ US(IJK1)=US(IJK1)+2*SRH*((-F(LR,2,KU)-F(LR,2,KV))
+ & *CLON(L,3)
+ & -(-F(LI,2,KU)-F(LI,2,KV))
+ & *SLON(L,3))
+ VS(IJK1)=VS(IJK1)+2*SRH*(( F(LR,2,KU)-F(LR,2,KV))
+ & *CLON(L,3)
+ & -( F(LI,2,KU)-F(LI,2,KV))
+ & *SLON(L,3))
+ US(IJK3)=US(IJK3)+2*SRH*(( F(LR,2,KU)-F(LR,2,KV))
+ & *CLON(L,1)
+ & -( F(LI,2,KU)-F(LI,2,KV))
+ & *SLON(L,1))
+ VS(IJK3)=VS(IJK3)+2*SRH*(( F(LR,2,KU)+F(LR,2,KV))
+ & *CLON(L,1)
+ & -( F(LI,2,KU)+F(LI,2,KV))
+ & *SLON(L,1))
+ US(IJK5)=US(IJK5)+2*SRH*(( F(LR,2,KU)+F(LR,2,KV))
+ & *CLON(L,7)
+ & -( F(LI,2,KU)+F(LI,2,KV))
+ & *SLON(L,7))
+ VS(IJK5)=VS(IJK5)+2*SRH*((-F(LR,2,KU)+F(LR,2,KV))
+ & *CLON(L,7)
+ & -(-F(LI,2,KU)+F(LI,2,KV))
+ & *SLON(L,7))
+ US(IJK7)=US(IJK7)+2*SRH*((-F(LR,2,KU)+F(LR,2,KV))
+ & *CLON(L,5)
+ & -(-F(LI,2,KU)+F(LI,2,KV))
+ & *SLON(L,5))
+ VS(IJK7)=VS(IJK7)+2*SRH*((-F(LR,2,KU)-F(LR,2,KV))
+ & *CLON(L,5)
+ & -(-F(LI,2,KU)-F(LI,2,KV))
+ & *SLON(L,5))
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDDO
+
+C CALCULATE THE REMAINDER OF THE POLAR STEREOGRAPHIC DOMAIN,
+C STARTING AT THE SECTOR JUST CLOCKWISE OF THE ORIENTATION LONGITUDE
+C AND GOING CLOCKWISE UNTIL ALL EIGHT SECTORS ARE DONE.
+C$OMP PARALLEL DO PRIVATE(I1,J2,I2,J3,I3,J4,I4,J5,I5,J6,I6,J7,I7,J8,I8)
+C$OMP& PRIVATE(IJ1,IJ2,IJ3,IJ4,IJ5,IJ6,IJ7,IJ8)
+C$OMP& PRIVATE(IJK1,IJK2,IJK3,IJK4,IJK5,IJK6,IJK7,IJK8)
+C$OMP& PRIVATE(DJ1,DI1,RQ,RR,RADLON,RADLON1,RADLON2,SLAT1,CLAT1)
+C$OMP& PRIVATE(PLN,PLNTOP,F,SLON,CLON,KU,KV,LR,LI)
+ DO J1=1,NPH-1
+ DO I1=J1+1,NPH
+ J2=I1
+ I2=J1
+ J3=NPS+1-I1
+ I3=J1
+ J4=NPS+1-J1
+ I4=I1
+ J5=NPS+1-J1
+ I5=NPS+1-I1
+ J6=NPS+1-I1
+ I6=NPS+1-J1
+ J7=I1
+ I7=NPS+1-J1
+ J8=J1
+ I8=NPS+1-I1
+ IJ1=(I1-1)*NI+(J1-1)*NJ+1
+ IJ2=(I2-1)*NI+(J2-1)*NJ+1
+ IJ3=(I3-1)*NI+(J3-1)*NJ+1
+ IJ4=(I4-1)*NI+(J4-1)*NJ+1
+ IJ5=(I5-1)*NI+(J5-1)*NJ+1
+ IJ6=(I6-1)*NI+(J6-1)*NJ+1
+ IJ7=(I7-1)*NI+(J7-1)*NJ+1
+ IJ8=(I8-1)*NI+(J8-1)*NJ+1
+ DI1=I1-NPH-1
+ DJ1=J1-NPH-1
+ RQ=DI1**2+DJ1**2
+ RR=SQRT(1/RQ)
+ SLAT1=(GQ-RQ)/(GQ+RQ)
+ CLAT1=SQRT(1.-SLAT1**2)
+ RADLON1=ORIENT/DPR+ATAN(-DI1/DJ1)
+ RADLON2=(ORIENT-45)/DPR*2-RADLON1
+ CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP,
+ & PLN,PLNTOP)
+ CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,MDIM,2*MXTOP,2*KMAX,
+ & CLAT1,PLN,PLNTOP,MP,W,WTOP,F)
+ DO L=1,MAXWV
+ SLON(L,1)=SIN(L*RADLON1)
+ CLON(L,1)=COS(L*RADLON1)
+ SLON(L,2)=SIN(L*RADLON2)
+ CLON(L,2)=COS(L*RADLON2)
+ SLON(L,3)=SLON(L,1)*CROT(MOD(1*L,4))
+ & -CLON(L,1)*SROT(MOD(1*L,4))
+ CLON(L,3)=CLON(L,1)*CROT(MOD(1*L,4))
+ & +SLON(L,1)*SROT(MOD(1*L,4))
+ SLON(L,4)=SLON(L,2)*CROT(MOD(1*L,4))
+ & -CLON(L,2)*SROT(MOD(1*L,4))
+ CLON(L,4)=CLON(L,2)*CROT(MOD(1*L,4))
+ & +SLON(L,2)*SROT(MOD(1*L,4))
+ SLON(L,5)=SLON(L,1)*CROT(MOD(2*L,4))
+ & -CLON(L,1)*SROT(MOD(2*L,4))
+ CLON(L,5)=CLON(L,1)*CROT(MOD(2*L,4))
+ & +SLON(L,1)*SROT(MOD(2*L,4))
+ SLON(L,6)=SLON(L,2)*CROT(MOD(2*L,4))
+ & -CLON(L,2)*SROT(MOD(2*L,4))
+ CLON(L,6)=CLON(L,2)*CROT(MOD(2*L,4))
+ & +SLON(L,2)*SROT(MOD(2*L,4))
+ SLON(L,7)=SLON(L,1)*CROT(MOD(3*L,4))
+ & -CLON(L,1)*SROT(MOD(3*L,4))
+ CLON(L,7)=CLON(L,1)*CROT(MOD(3*L,4))
+ & +SLON(L,1)*SROT(MOD(3*L,4))
+ SLON(L,8)=SLON(L,2)*CROT(MOD(3*L,4))
+ & -CLON(L,2)*SROT(MOD(3*L,4))
+ CLON(L,8)=CLON(L,2)*CROT(MOD(3*L,4))
+ & +SLON(L,2)*SROT(MOD(3*L,4))
+ ENDDO
+CDIR$ IVDEP
+ DO K=1,KMAX
+ KU=K
+ KV=K+KMAX
+ IJK1=IJ1+(K-1)*KG
+ IJK2=IJ2+(K-1)*KG
+ IJK3=IJ3+(K-1)*KG
+ IJK4=IJ4+(K-1)*KG
+ IJK5=IJ5+(K-1)*KG
+ IJK6=IJ6+(K-1)*KG
+ IJK7=IJ7+(K-1)*KG
+ IJK8=IJ8+(K-1)*KG
+ UN(IJK1)=RR*(-DJ1*F(1,1,KU)-DI1*F(1,1,KV))
+ VN(IJK1)=RR*( DI1*F(1,1,KU)-DJ1*F(1,1,KV))
+ UN(IJK2)=RR*(-DI1*F(1,1,KU)-DJ1*F(1,1,KV))
+ VN(IJK2)=RR*( DJ1*F(1,1,KU)-DI1*F(1,1,KV))
+ UN(IJK3)=RR*( DI1*F(1,1,KU)-DJ1*F(1,1,KV))
+ VN(IJK3)=RR*( DJ1*F(1,1,KU)+DI1*F(1,1,KV))
+ UN(IJK4)=RR*( DJ1*F(1,1,KU)-DI1*F(1,1,KV))
+ VN(IJK4)=RR*( DI1*F(1,1,KU)+DJ1*F(1,1,KV))
+ UN(IJK5)=RR*( DJ1*F(1,1,KU)+DI1*F(1,1,KV))
+ VN(IJK5)=RR*(-DI1*F(1,1,KU)+DJ1*F(1,1,KV))
+ UN(IJK6)=RR*( DI1*F(1,1,KU)+DJ1*F(1,1,KV))
+ VN(IJK6)=RR*(-DJ1*F(1,1,KU)+DI1*F(1,1,KV))
+ UN(IJK7)=RR*(-DI1*F(1,1,KU)+DJ1*F(1,1,KV))
+ VN(IJK7)=RR*(-DJ1*F(1,1,KU)-DI1*F(1,1,KV))
+ UN(IJK8)=RR*(-DJ1*F(1,1,KU)+DI1*F(1,1,KV))
+ VN(IJK8)=RR*(-DI1*F(1,1,KU)-DJ1*F(1,1,KV))
+ US(IJK1)=RR*( DJ1*F(1,2,KU)+DI1*F(1,2,KV))
+ VS(IJK1)=RR*(-DI1*F(1,2,KU)+DJ1*F(1,2,KV))
+ US(IJK2)=RR*( DI1*F(1,2,KU)+DJ1*F(1,2,KV))
+ VS(IJK2)=RR*(-DJ1*F(1,2,KU)+DI1*F(1,2,KV))
+ US(IJK3)=RR*(-DI1*F(1,2,KU)+DJ1*F(1,2,KV))
+ VS(IJK3)=RR*(-DJ1*F(1,2,KU)-DI1*F(1,2,KV))
+ US(IJK4)=RR*(-DJ1*F(1,2,KU)+DI1*F(1,2,KV))
+ VS(IJK4)=RR*(-DI1*F(1,2,KU)-DJ1*F(1,2,KV))
+ US(IJK5)=RR*(-DJ1*F(1,2,KU)-DI1*F(1,2,KV))
+ VS(IJK5)=RR*( DI1*F(1,2,KU)-DJ1*F(1,2,KV))
+ US(IJK6)=RR*(-DI1*F(1,2,KU)-DJ1*F(1,2,KV))
+ VS(IJK6)=RR*( DJ1*F(1,2,KU)-DI1*F(1,2,KV))
+ US(IJK7)=RR*( DI1*F(1,2,KU)-DJ1*F(1,2,KV))
+ VS(IJK7)=RR*( DJ1*F(1,2,KU)+DI1*F(1,2,KV))
+ US(IJK8)=RR*( DJ1*F(1,2,KU)-DI1*F(1,2,KV))
+ VS(IJK8)=RR*( DI1*F(1,2,KU)+DJ1*F(1,2,KV))
+ ENDDO
+ IF(KMAX.EQ.1) THEN
+ KU=1
+ KV=2
+ DO L=1,MAXWV
+ LR=2*L+1
+ LI=2*L+2
+ UN(IJ1)=UN(IJ1)+2*RR*((-DJ1*F(LR,1,KU)-DI1*F(LR,1,KV))
+ & *CLON(L,1)
+ & -(-DJ1*F(LI,1,KU)-DI1*F(LI,1,KV))
+ & *SLON(L,1))
+ VN(IJ1)=VN(IJ1)+2*RR*(( DI1*F(LR,1,KU)-DJ1*F(LR,1,KV))
+ & *CLON(L,1)
+ & -( DI1*F(LI,1,KU)-DJ1*F(LI,1,KV))
+ & *SLON(L,1))
+ UN(IJ2)=UN(IJ2)+2*RR*((-DI1*F(LR,1,KU)-DJ1*F(LR,1,KV))
+ & *CLON(L,2)
+ & -(-DI1*F(LI,1,KU)-DJ1*F(LI,1,KV))
+ & *SLON(L,2))
+ VN(IJ2)=VN(IJ2)+2*RR*(( DJ1*F(LR,1,KU)-DI1*F(LR,1,KV))
+ & *CLON(L,2)
+ & -( DJ1*F(LI,1,KU)-DI1*F(LI,1,KV))
+ & *SLON(L,2))
+ UN(IJ3)=UN(IJ3)+2*RR*(( DI1*F(LR,1,KU)-DJ1*F(LR,1,KV))
+ & *CLON(L,3)
+ & -( DI1*F(LI,1,KU)-DJ1*F(LI,1,KV))
+ & *SLON(L,3))
+ VN(IJ3)=VN(IJ3)+2*RR*(( DJ1*F(LR,1,KU)+DI1*F(LR,1,KV))
+ & *CLON(L,3)
+ & -( DJ1*F(LI,1,KU)+DI1*F(LI,1,KV))
+ & *SLON(L,3))
+ UN(IJ4)=UN(IJ4)+2*RR*(( DJ1*F(LR,1,KU)-DI1*F(LR,1,KV))
+ & *CLON(L,4)
+ & -( DJ1*F(LI,1,KU)-DI1*F(LI,1,KV))
+ & *SLON(L,4))
+ VN(IJ4)=VN(IJ4)+2*RR*(( DI1*F(LR,1,KU)+DJ1*F(LR,1,KV))
+ & *CLON(L,4)
+ & -( DI1*F(LI,1,KU)+DJ1*F(LI,1,KV))
+ & *SLON(L,4))
+ UN(IJ5)=UN(IJ5)+2*RR*(( DJ1*F(LR,1,KU)+DI1*F(LR,1,KV))
+ & *CLON(L,5)
+ & -( DJ1*F(LI,1,KU)+DI1*F(LI,1,KV))
+ & *SLON(L,5))
+ VN(IJ5)=VN(IJ5)+2*RR*((-DI1*F(LR,1,KU)+DJ1*F(LR,1,KV))
+ & *CLON(L,5)
+ & -(-DI1*F(LI,1,KU)+DJ1*F(LI,1,KV))
+ & *SLON(L,5))
+ UN(IJ6)=UN(IJ6)+2*RR*(( DI1*F(LR,1,KU)+DJ1*F(LR,1,KV))
+ & *CLON(L,6)
+ & -( DI1*F(LI,1,KU)+DJ1*F(LI,1,KV))
+ & *SLON(L,6))
+ VN(IJ6)=VN(IJ6)+2*RR*((-DJ1*F(LR,1,KU)+DI1*F(LR,1,KV))
+ & *CLON(L,6)
+ & -(-DJ1*F(LI,1,KU)+DI1*F(LI,1,KV))
+ & *SLON(L,6))
+ UN(IJ7)=UN(IJ7)+2*RR*((-DI1*F(LR,1,KU)+DJ1*F(LR,1,KV))
+ & *CLON(L,7)
+ & -(-DI1*F(LI,1,KU)+DJ1*F(LI,1,KV))
+ & *SLON(L,7))
+ VN(IJ7)=VN(IJ7)+2*RR*((-DJ1*F(LR,1,KU)-DI1*F(LR,1,KV))
+ & *CLON(L,7)
+ & -(-DJ1*F(LI,1,KU)-DI1*F(LI,1,KV))
+ & *SLON(L,7))
+ UN(IJ8)=UN(IJ8)+2*RR*((-DJ1*F(LR,1,KU)+DI1*F(LR,1,KV))
+ & *CLON(L,8)
+ & -(-DJ1*F(LI,1,KU)+DI1*F(LI,1,KV))
+ & *SLON(L,8))
+ VN(IJ8)=VN(IJ8)+2*RR*((-DI1*F(LR,1,KU)-DJ1*F(LR,1,KV))
+ & *CLON(L,8)
+ & -(-DI1*F(LI,1,KU)-DJ1*F(LI,1,KV))
+ & *SLON(L,8))
+ US(IJ1)=US(IJ1)+2*RR*(( DJ1*F(LR,2,KU)+DI1*F(LR,2,KV))
+ & *CLON(L,4)
+ & -( DJ1*F(LI,2,KU)+DI1*F(LI,2,KV))
+ & *SLON(L,4))
+ VS(IJ1)=VS(IJ1)+2*RR*((-DI1*F(LR,2,KU)+DJ1*F(LR,2,KV))
+ & *CLON(L,4)
+ & -(-DI1*F(LI,2,KU)+DJ1*F(LI,2,KV))
+ & *SLON(L,4))
+ US(IJ2)=US(IJ2)+2*RR*(( DI1*F(LR,2,KU)+DJ1*F(LR,2,KV))
+ & *CLON(L,3)
+ & -( DI1*F(LI,2,KU)+DJ1*F(LI,2,KV))
+ & *SLON(L,3))
+ VS(IJ2)=VS(IJ2)+2*RR*((-DJ1*F(LR,2,KU)+DI1*F(LR,2,KV))
+ & *CLON(L,3)
+ & -(-DJ1*F(LI,2,KU)+DI1*F(LI,2,KV))
+ & *SLON(L,3))
+ US(IJ3)=US(IJ3)+2*RR*((-DI1*F(LR,2,KU)+DJ1*F(LR,2,KV))
+ & *CLON(L,2)
+ & -(-DI1*F(LI,2,KU)+DJ1*F(LI,2,KV))
+ & *SLON(L,2))
+ VS(IJ3)=VS(IJ3)+2*RR*((-DJ1*F(LR,2,KU)-DI1*F(LR,2,KV))
+ & *CLON(L,2)
+ & -(-DJ1*F(LI,2,KU)-DI1*F(LI,2,KV))
+ & *SLON(L,2))
+ US(IJ4)=US(IJ4)+2*RR*((-DJ1*F(LR,2,KU)+DI1*F(LR,2,KV))
+ & *CLON(L,1)
+ & -(-DJ1*F(LI,2,KU)+DI1*F(LI,2,KV))
+ & *SLON(L,1))
+ VS(IJ4)=VS(IJ4)+2*RR*((-DI1*F(LR,2,KU)-DJ1*F(LR,2,KV))
+ & *CLON(L,1)
+ & -(-DI1*F(LI,2,KU)-DJ1*F(LI,2,KV))
+ & *SLON(L,1))
+ US(IJ5)=US(IJ5)+2*RR*((-DJ1*F(LR,2,KU)-DI1*F(LR,2,KV))
+ & *CLON(L,8)
+ & -(-DJ1*F(LI,2,KU)-DI1*F(LI,2,KV))
+ & *SLON(L,8))
+ VS(IJ5)=VS(IJ5)+2*RR*(( DI1*F(LR,2,KU)-DJ1*F(LR,2,KV))
+ & *CLON(L,8)
+ & -( DI1*F(LI,2,KU)-DJ1*F(LI,2,KV))
+ & *SLON(L,8))
+ US(IJ6)=US(IJ6)+2*RR*((-DI1*F(LR,2,KU)-DJ1*F(LR,2,KV))
+ & *CLON(L,7)
+ & -(-DI1*F(LI,2,KU)-DJ1*F(LI,2,KV))
+ & *SLON(L,7))
+ VS(IJ6)=VS(IJ6)+2*RR*(( DJ1*F(LR,2,KU)-DI1*F(LR,2,KV))
+ & *CLON(L,7)
+ & -( DJ1*F(LI,2,KU)-DI1*F(LI,2,KV))
+ & *SLON(L,7))
+ US(IJ7)=US(IJ7)+2*RR*(( DI1*F(LR,2,KU)-DJ1*F(LR,2,KV))
+ & *CLON(L,6)
+ & -( DI1*F(LI,2,KU)-DJ1*F(LI,2,KV))
+ & *SLON(L,6))
+ VS(IJ7)=VS(IJ7)+2*RR*(( DJ1*F(LR,2,KU)+DI1*F(LR,2,KV))
+ & *CLON(L,6)
+ & -( DJ1*F(LI,2,KU)+DI1*F(LI,2,KV))
+ & *SLON(L,6))
+ US(IJ8)=US(IJ8)+2*RR*(( DJ1*F(LR,2,KU)-DI1*F(LR,2,KV))
+ & *CLON(L,5)
+ & -( DJ1*F(LI,2,KU)-DI1*F(LI,2,KV))
+ & *SLON(L,5))
+ VS(IJ8)=VS(IJ8)+2*RR*(( DI1*F(LR,2,KU)+DJ1*F(LR,2,KV))
+ & *CLON(L,5)
+ & -( DI1*F(LI,2,KU)+DJ1*F(LI,2,KV))
+ & *SLON(L,5))
+ ENDDO
+ ELSE
+ DO L=1,MAXWV
+ LR=2*L+1
+ LI=2*L+2
+CDIR$ IVDEP
+ DO K=1,KMAX
+ KU=K
+ KV=K+KMAX
+ IJK1=IJ1+(K-1)*KG
+ IJK2=IJ2+(K-1)*KG
+ IJK3=IJ3+(K-1)*KG
+ IJK4=IJ4+(K-1)*KG
+ IJK5=IJ5+(K-1)*KG
+ IJK6=IJ6+(K-1)*KG
+ IJK7=IJ7+(K-1)*KG
+ IJK8=IJ8+(K-1)*KG
+ UN(IJK1)=UN(IJK1)+2*RR*((-DJ1*F(LR,1,KU)-DI1*F(LR,1,KV))
+ & *CLON(L,1)
+ & -(-DJ1*F(LI,1,KU)-DI1*F(LI,1,KV))
+ & *SLON(L,1))
+ VN(IJK1)=VN(IJK1)+2*RR*(( DI1*F(LR,1,KU)-DJ1*F(LR,1,KV))
+ & *CLON(L,1)
+ & -( DI1*F(LI,1,KU)-DJ1*F(LI,1,KV))
+ & *SLON(L,1))
+ UN(IJK2)=UN(IJK2)+2*RR*((-DI1*F(LR,1,KU)-DJ1*F(LR,1,KV))
+ & *CLON(L,2)
+ & -(-DI1*F(LI,1,KU)-DJ1*F(LI,1,KV))
+ & *SLON(L,2))
+ VN(IJK2)=VN(IJK2)+2*RR*(( DJ1*F(LR,1,KU)-DI1*F(LR,1,KV))
+ & *CLON(L,2)
+ & -( DJ1*F(LI,1,KU)-DI1*F(LI,1,KV))
+ & *SLON(L,2))
+ UN(IJK3)=UN(IJK3)+2*RR*(( DI1*F(LR,1,KU)-DJ1*F(LR,1,KV))
+ & *CLON(L,3)
+ & -( DI1*F(LI,1,KU)-DJ1*F(LI,1,KV))
+ & *SLON(L,3))
+ VN(IJK3)=VN(IJK3)+2*RR*(( DJ1*F(LR,1,KU)+DI1*F(LR,1,KV))
+ & *CLON(L,3)
+ & -( DJ1*F(LI,1,KU)+DI1*F(LI,1,KV))
+ & *SLON(L,3))
+ UN(IJK4)=UN(IJK4)+2*RR*(( DJ1*F(LR,1,KU)-DI1*F(LR,1,KV))
+ & *CLON(L,4)
+ & -( DJ1*F(LI,1,KU)-DI1*F(LI,1,KV))
+ & *SLON(L,4))
+ VN(IJK4)=VN(IJK4)+2*RR*(( DI1*F(LR,1,KU)+DJ1*F(LR,1,KV))
+ & *CLON(L,4)
+ & -( DI1*F(LI,1,KU)+DJ1*F(LI,1,KV))
+ & *SLON(L,4))
+ UN(IJK5)=UN(IJK5)+2*RR*(( DJ1*F(LR,1,KU)+DI1*F(LR,1,KV))
+ & *CLON(L,5)
+ & -( DJ1*F(LI,1,KU)+DI1*F(LI,1,KV))
+ & *SLON(L,5))
+ VN(IJK5)=VN(IJK5)+2*RR*((-DI1*F(LR,1,KU)+DJ1*F(LR,1,KV))
+ & *CLON(L,5)
+ & -(-DI1*F(LI,1,KU)+DJ1*F(LI,1,KV))
+ & *SLON(L,5))
+ UN(IJK6)=UN(IJK6)+2*RR*(( DI1*F(LR,1,KU)+DJ1*F(LR,1,KV))
+ & *CLON(L,6)
+ & -( DI1*F(LI,1,KU)+DJ1*F(LI,1,KV))
+ & *SLON(L,6))
+ VN(IJK6)=VN(IJK6)+2*RR*((-DJ1*F(LR,1,KU)+DI1*F(LR,1,KV))
+ & *CLON(L,6)
+ & -(-DJ1*F(LI,1,KU)+DI1*F(LI,1,KV))
+ & *SLON(L,6))
+ UN(IJK7)=UN(IJK7)+2*RR*((-DI1*F(LR,1,KU)+DJ1*F(LR,1,KV))
+ & *CLON(L,7)
+ & -(-DI1*F(LI,1,KU)+DJ1*F(LI,1,KV))
+ & *SLON(L,7))
+ VN(IJK7)=VN(IJK7)+2*RR*((-DJ1*F(LR,1,KU)-DI1*F(LR,1,KV))
+ & *CLON(L,7)
+ & -(-DJ1*F(LI,1,KU)-DI1*F(LI,1,KV))
+ & *SLON(L,7))
+ UN(IJK8)=UN(IJK8)+2*RR*((-DJ1*F(LR,1,KU)+DI1*F(LR,1,KV))
+ & *CLON(L,8)
+ & -(-DJ1*F(LI,1,KU)+DI1*F(LI,1,KV))
+ & *SLON(L,8))
+ VN(IJK8)=VN(IJK8)+2*RR*((-DI1*F(LR,1,KU)-DJ1*F(LR,1,KV))
+ & *CLON(L,8)
+ & -(-DI1*F(LI,1,KU)-DJ1*F(LI,1,KV))
+ & *SLON(L,8))
+ US(IJK1)=US(IJK1)+2*RR*(( DJ1*F(LR,2,KU)+DI1*F(LR,2,KV))
+ & *CLON(L,4)
+ & -( DJ1*F(LI,2,KU)+DI1*F(LI,2,KV))
+ & *SLON(L,4))
+ VS(IJK1)=VS(IJK1)+2*RR*((-DI1*F(LR,2,KU)+DJ1*F(LR,2,KV))
+ & *CLON(L,4)
+ & -(-DI1*F(LI,2,KU)+DJ1*F(LI,2,KV))
+ & *SLON(L,4))
+ US(IJK2)=US(IJK2)+2*RR*(( DI1*F(LR,2,KU)+DJ1*F(LR,2,KV))
+ & *CLON(L,3)
+ & -( DI1*F(LI,2,KU)+DJ1*F(LI,2,KV))
+ & *SLON(L,3))
+ VS(IJK2)=VS(IJK2)+2*RR*((-DJ1*F(LR,2,KU)+DI1*F(LR,2,KV))
+ & *CLON(L,3)
+ & -(-DJ1*F(LI,2,KU)+DI1*F(LI,2,KV))
+ & *SLON(L,3))
+ US(IJK3)=US(IJK3)+2*RR*((-DI1*F(LR,2,KU)+DJ1*F(LR,2,KV))
+ & *CLON(L,2)
+ & -(-DI1*F(LI,2,KU)+DJ1*F(LI,2,KV))
+ & *SLON(L,2))
+ VS(IJK3)=VS(IJK3)+2*RR*((-DJ1*F(LR,2,KU)-DI1*F(LR,2,KV))
+ & *CLON(L,2)
+ & -(-DJ1*F(LI,2,KU)-DI1*F(LI,2,KV))
+ & *SLON(L,2))
+ US(IJK4)=US(IJK4)+2*RR*((-DJ1*F(LR,2,KU)+DI1*F(LR,2,KV))
+ & *CLON(L,1)
+ & -(-DJ1*F(LI,2,KU)+DI1*F(LI,2,KV))
+ & *SLON(L,1))
+ VS(IJK4)=VS(IJK4)+2*RR*((-DI1*F(LR,2,KU)-DJ1*F(LR,2,KV))
+ & *CLON(L,1)
+ & -(-DI1*F(LI,2,KU)-DJ1*F(LI,2,KV))
+ & *SLON(L,1))
+ US(IJK5)=US(IJK5)+2*RR*((-DJ1*F(LR,2,KU)-DI1*F(LR,2,KV))
+ & *CLON(L,8)
+ & -(-DJ1*F(LI,2,KU)-DI1*F(LI,2,KV))
+ & *SLON(L,8))
+ VS(IJK5)=VS(IJK5)+2*RR*(( DI1*F(LR,2,KU)-DJ1*F(LR,2,KV))
+ & *CLON(L,8)
+ & -( DI1*F(LI,2,KU)-DJ1*F(LI,2,KV))
+ & *SLON(L,8))
+ US(IJK6)=US(IJK6)+2*RR*((-DI1*F(LR,2,KU)-DJ1*F(LR,2,KV))
+ & *CLON(L,7)
+ & -(-DI1*F(LI,2,KU)-DJ1*F(LI,2,KV))
+ & *SLON(L,7))
+ VS(IJK6)=VS(IJK6)+2*RR*(( DJ1*F(LR,2,KU)-DI1*F(LR,2,KV))
+ & *CLON(L,7)
+ & -( DJ1*F(LI,2,KU)-DI1*F(LI,2,KV))
+ & *SLON(L,7))
+ US(IJK7)=US(IJK7)+2*RR*(( DI1*F(LR,2,KU)-DJ1*F(LR,2,KV))
+ & *CLON(L,6)
+ & -( DI1*F(LI,2,KU)-DJ1*F(LI,2,KV))
+ & *SLON(L,6))
+ VS(IJK7)=VS(IJK7)+2*RR*(( DJ1*F(LR,2,KU)+DI1*F(LR,2,KV))
+ & *CLON(L,6)
+ & -( DJ1*F(LI,2,KU)+DI1*F(LI,2,KV))
+ & *SLON(L,6))
+ US(IJK8)=US(IJK8)+2*RR*(( DJ1*F(LR,2,KU)-DI1*F(LR,2,KV))
+ & *CLON(L,5)
+ & -( DJ1*F(LI,2,KU)-DI1*F(LI,2,KV))
+ & *SLON(L,5))
+ VS(IJK8)=VS(IJK8)+2*RR*(( DI1*F(LR,2,KU)+DJ1*F(LR,2,KV))
+ & *CLON(L,5)
+ & -( DI1*F(LI,2,KU)+DJ1*F(LI,2,KV))
+ & *SLON(L,5))
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDDO
+ ENDDO
+
+ END
diff --git a/src/sptgpt.f b/src/sptgpt.f
new file mode 100644
index 00000000..cec003f0
--- /dev/null
+++ b/src/sptgpt.f
@@ -0,0 +1,104 @@
+C> @file
+C> @brief Transform spectral scalar to station points.
+C>
+C> ### Program History Log
+C> Date | Programmer | Comments
+C> -----|------------|---------
+C> 96-02-29 | Iredell | Initial.
+C> 1998-12-15 | Iredell | Openmp directives inserted.
+C> 2003-06-30 | Iredell | Use spfftpt().
+C>
+C> @author Iredell @date 96-02-29
+
+C> This subprogram performs a spherical transform
+c> from spectral coefficients of scalar quantities
+c> to specified sets of station points on the globe.
+C>
+C> The wave-space can be either triangular or rhomboidal.
+C>
+C> The wave and point fields may have general indexing,
+c> but each wave field is in sequential 'IBM order',
+c> i.e. with zonal wavenumber as the slower index.
+C>
+C> The transforms are all multiprocessed over stations.
+C>
+C> Transform several fields at a time to improve vectorization.
+C>
+C> Subprogram can be called from a multiprocessing environment.
+C>
+C> @param IROMB spectral domain shape
+C> (0 for triangular, 1 for rhomboidal)
+C> @param MAXWV spectral truncation
+C> @param KMAX number of fields to transform.
+C> @param NMAX number of station points to return
+C> @param KWSKIP skip number between wave fields
+C> (defaults to (MAXWV+1)*((IROMB+1)*MAXWV+2) if KWSKIP=0)
+C> @param KGSKIP skip number between station point sets
+C> (defaults to NMAX if KGSKIP=0)
+C> @param NRSKIP skip number between station lats and lons
+C> (defaults to 1 if NRSKIP=0)
+C> @param NGSKIP skip number between station points
+C> (defaults to 1 if NGSKIP=0)
+C> @param RLAT station latitudes in degrees
+C> @param RLON station longitudes in degrees
+C> @param WAVE wave fields
+C> @param GP station point sets
+C>
+C> @author Iredell @date 96-02-29
+ SUBROUTINE SPTGPT(IROMB,MAXWV,KMAX,NMAX,
+ & KWSKIP,KGSKIP,NRSKIP,NGSKIP,
+ & RLAT,RLON,WAVE,GP)
+
+ REAL RLAT(*),RLON(*),WAVE(*),GP(*)
+ REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1)
+ REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1)
+ INTEGER MP(KMAX)
+ REAL WTOP(2*(MAXWV+1),KMAX)
+ REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),PLNTOP(MAXWV+1)
+ REAL F(2*MAXWV+3,2,KMAX)
+ PARAMETER(PI=3.14159265358979)
+
+C CALCULATE PRELIMINARY CONSTANTS
+ CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP)
+ MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+ MXTOP=MAXWV+1
+ IDIM=2*MAXWV+3
+ KW=KWSKIP
+ KG=KGSKIP
+ NR=NRSKIP
+ NG=NGSKIP
+ IF(KW.EQ.0) KW=2*MX
+ IF(KG.EQ.0) KG=NMAX
+ IF(NR.EQ.0) NR=1
+ IF(NG.EQ.0) NG=1
+ MP=0
+C$OMP PARALLEL DO
+ DO K=1,KMAX
+ WTOP(1:2*MXTOP,K)=0
+ ENDDO
+
+C CALCULATE STATION FIELDS
+C$OMP PARALLEL DO PRIVATE(RADLAT,SLAT1,CLAT1)
+C$OMP& PRIVATE(PLN,PLNTOP,F,NK)
+ DO N=1,NMAX
+ RADLAT=PI/180*RLAT((N-1)*NR+1)
+ IF(RLAT((N-1)*NR+1).GE.89.9995) THEN
+ SLAT1=1.
+ CLAT1=0.
+ ELSEIF(RLAT((N-1)*NR+1).LE.-89.9995) THEN
+ SLAT1=-1.
+ CLAT1=0.
+ ELSE
+ SLAT1=SIN(RADLAT)
+ CLAT1=COS(RADLAT)
+ ENDIF
+ CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP,
+ & PLN,PLNTOP)
+ CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,KW,2*MXTOP,KMAX,
+ & CLAT1,PLN,PLNTOP,MP,WAVE,WTOP,F)
+ CALL SPFFTPT(MAXWV,1,2*MAXWV+3,KG,KMAX,RLON((N-1)*NR+1),
+ & F,GP((N-1)*NG+1))
+ ENDDO
+ END
diff --git a/src/sptgptd.f b/src/sptgptd.f
new file mode 100644
index 00000000..e0d99e19
--- /dev/null
+++ b/src/sptgptd.f
@@ -0,0 +1,77 @@
+C> @file
+C> @brief Transform spectral to station point gradients.
+C>
+C> ### Program History Log
+C> Date | Programmer | Comments
+C> -----|------------|---------
+C> 96-02-29 | Iredell | Initial.
+C> 1998-12-15 | Iredell | Openmp directives inserted.
+C>
+C> @author Iredell @date 96-02-29
+
+C> This subprogram performs a spherical transform
+c> from spectral coefficients of scalar fields
+c> to specified sets of station point gradients on the globe.
+C>
+C> The wave-space can be either triangular or rhomboidal.
+C>
+C> The wave and point fields may have general indexing,
+c> but each wave field is in sequential 'IBM order',
+c> i.e. with zonal wavenumber as the slower index.
+C>
+C> The transforms are all multiprocessed over stations.
+C>
+C> Transform several fields at a time to improve vectorization.
+C>
+C> Subprogram can be called from a multiprocessing environment.
+C>
+C> @param IROMB spectral domain shape
+c> (0 for triangular, 1 for rhomboidal)
+C> @param MAXWV spectral truncation
+C> @param KMAX number of fields to transform.
+C> @param NMAX number of station points to return
+C> @param KWSKIP skip number between wave fields
+C> (defaults to (MAXWV+1)*((IROMB+1)*MAXWV+2) if KWSKIP=0)
+C> @param KGSKIP skip number between station point sets
+C> (defaults to NMAX if KGSKIP=0)
+C> @param NRSKIP skip number between station lats and lons
+C> (defaults to 1 if NRSKIP=0)
+C> @param NGSKIP skip number between station points
+c> (defaults to 1 if NGSKIP=0)
+C> @param RLAT station latitudes in degrees
+C> @param RLON station longitudes in degrees
+C> @param WAVE wave fields
+C> @param XP station point x-gradient sets
+C> @param YP station point y-gradient sets
+C>
+C> @author Iredell @date 96-02-29
+ SUBROUTINE SPTGPTD(IROMB,MAXWV,KMAX,NMAX,
+ & KWSKIP,KGSKIP,NRSKIP,NGSKIP,
+ & RLAT,RLON,WAVE,XP,YP)
+
+ REAL RLAT(*),RLON(*),WAVE(*),XP(*),YP(*)
+ REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1)
+ REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1)
+ REAL WD((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX)
+ REAL WZ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C CALCULATE PRELIMINARY CONSTANTS
+ CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP)
+ MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+ MDIM=2*MX+1
+ KW=KWSKIP
+ IF(KW.EQ.0) KW=2*MX
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C CALCULATE STATION FIELDS
+C$OMP PARALLEL DO PRIVATE(KWS)
+ DO K=1,KMAX
+ KWS=(K-1)*KW
+ CALL SPLAPLAC(IROMB,MAXWV,ENN1,WAVE(KWS+1),WD(1,K),1)
+ WZ(1:2*MX,K)=0.
+ ENDDO
+ CALL SPTGPTV(IROMB,MAXWV,KMAX,NMAX,MDIM,KGSKIP,NRSKIP,NGSKIP,
+ & RLAT,RLON,WD,WZ,XP,YP)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ END
diff --git a/src/sptgptsd.f b/src/sptgptsd.f
new file mode 100644
index 00000000..b22dfa51
--- /dev/null
+++ b/src/sptgptsd.f
@@ -0,0 +1,130 @@
+C> @file
+C> @brief Transform spectral scalar to station points.
+C> @author Iredell @date 96-02-29
+C>
+C> ### Program History Log
+C> Date | Programmer | Comments
+C> -----|------------|---------
+C> 96-02-29 | Iredell | Initial.
+C> 1998-12-15 | Iredell | Openmp directives inserted.
+C> 1999-08-18 | Iredell | Openmp directive typo fixed.
+C>
+C> @author Iredell @date 96-02-29
+
+C> This subprogram performs a spherical transform
+C> from spectral coefficients of scalar quantities
+C> to specified sets of station point values
+C> and their gradients on the globe.
+C>
+C> The wave-space can be either triangular or rhomboidal.
+C>
+C> The wave and point fields may have general indexing,
+C> but each wave field is in sequential 'IBM order',
+C> i.e. with zonal wavenumber as the slower index.
+C>
+C> The transforms are all multiprocessed over stations.
+C>
+C> Transform several fields at a time to improve vectorization.
+C>
+C> Subprogram can be called from a multiprocessing environment.
+C>
+C> @param IROMB spectral domain shape
+C> (0 for triangular, 1 for rhomboidal)
+C> @param MAXWV spectral truncation
+C> @param KMAX number of fields to transform.
+C> @param NMAX number of station points to return
+C> @param KWSKIP skip number between wave fields
+C> (defaults to (MAXWV+1)*((IROMB+1)*MAXWV+2) if KWSKIP=0)
+C> @param KGSKIP skip number between station point sets
+C> (defaults to NMAX if KGSKIP=0)
+C> @param NRSKIP skip number between station lats and lons
+C> (defaults to 1 if NRSKIP=0)
+C> @param NGSKIP skip number between station points
+C> (defaults to 1 if NGSKIP=0)
+C> @param RLAT station latitudes in degrees
+C> @param RLON station longitudes in degrees
+C> @param WAVE wave fields
+C> @param GP station point sets
+C> @param XP station point x-gradient sets
+C> @param YP station point y-gradient sets
+C>
+C> @author Iredell @date 96-02-29
+ SUBROUTINE SPTGPTSD(IROMB,MAXWV,KMAX,NMAX,
+ & KWSKIP,KGSKIP,NRSKIP,NGSKIP,
+ & RLAT,RLON,WAVE,GP,XP,YP)
+
+ REAL RLAT(*),RLON(*),WAVE(*)
+ REAL GP(*),XP(*),YP(*)
+ REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1)
+ REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1)
+ INTEGER MP(2*KMAX)
+ REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2,2*KMAX)
+ REAL WTOP(2*(MAXWV+1),2*KMAX)
+ REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),PLNTOP(MAXWV+1)
+ REAL F(2*MAXWV+2,2,3*KMAX),G(3*KMAX)
+ PARAMETER(PI=3.14159265358979)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C CALCULATE PRELIMINARY CONSTANTS
+ CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP)
+ MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+ MXTOP=MAXWV+1
+ MDIM=2*MX
+ IDIM=2*MAXWV+2
+ KW=KWSKIP
+ KG=KGSKIP
+ NR=NRSKIP
+ NG=NGSKIP
+ IF(KW.EQ.0) KW=2*MX
+ IF(KG.EQ.0) KG=NMAX
+ IF(NR.EQ.0) NR=1
+ IF(NG.EQ.0) NG=1
+ MP(1:KMAX)=10
+ MP(KMAX+1:2*KMAX)=1
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C CALCULATE SPECTRAL WINDS
+C$OMP PARALLEL DO PRIVATE(KWS,KS,KY)
+ DO K=1,KMAX
+ KWS=(K-1)*KW
+ KS=0*KMAX+K
+ KY=1*KMAX+K
+ DO I=1,2*MX
+ W(I,KS)=WAVE(KWS+I)
+ ENDDO
+ DO I=1,2*MXTOP
+ WTOP(I,KS)=0
+ ENDDO
+ CALL SPGRADY(IROMB,MAXWV,ENN1,EON,EONTOP,
+ & WAVE(KWS+1),W(1,KY),WTOP(1,KY))
+ ENDDO
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C CALCULATE STATION FIELDS
+C$OMP PARALLEL DO PRIVATE(KS,KY,KX,SLAT1,CLAT1)
+C$OMP& PRIVATE(PLN,PLNTOP,F,G,NK)
+ DO N=1,NMAX
+ IF(ABS(RLAT((N-1)*NR+1)).GE.89.9995) THEN
+ SLAT1=SIGN(1.,RLAT((N-1)*NR+1))
+ CLAT1=0.
+ ELSE
+ SLAT1=SIN(PI/180*RLAT((N-1)*NR+1))
+ CLAT1=COS(PI/180*RLAT((N-1)*NR+1))
+ ENDIF
+ CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP,
+ & PLN,PLNTOP)
+ CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,MDIM,2*MXTOP,2*KMAX,
+ & CLAT1,PLN,PLNTOP,MP,W,WTOP,F)
+ CALL SPGRADX(MAXWV,IDIM,KMAX,MP,CLAT1,F(1,1,1),F(1,1,2*KMAX+1))
+ CALL SPFFTPT(MAXWV,1,IDIM,1,3*KMAX,RLON((N-1)*NR+1),F,G)
+ DO K=1,KMAX
+ KS=0*KMAX+K
+ KY=1*KMAX+K
+ KX=2*KMAX+K
+ NK=(N-1)*NG+(K-1)*KG+1
+ GP(NK)=G(KS)
+ XP(NK)=G(KX)
+ YP(NK)=G(KY)
+ ENDDO
+ ENDDO
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ END
diff --git a/src/sptgptv.f b/src/sptgptv.f
new file mode 100644
index 00000000..37cf3b05
--- /dev/null
+++ b/src/sptgptv.f
@@ -0,0 +1,122 @@
+C> @file
+C> @brief Transform spectral vector to station points.
+C>
+C> ### Program History Log
+C> Date | Programmer | Comments
+C> -----|------------|---------
+C> 96-02-29 | IREDELL | Initial
+C> 1998-12-15 | IREDELL | Openmp directives inserted
+C> 1999-08-18 | IREDELL | Openmp directive typo fixed
+C> 2003-06-30 | IREDELL | use spfftpt()
+C>
+C> @author IREDELL @date 96-02-29
+
+C> This subprogram performs a spherical transform
+C> from spectral coefficients of divergences and curls
+C> to specified sets of station point vectors on the globe.
+C>
+C> The wave-space can be either triangular or rhomboidal.
+C>
+C> The wave and point fields may have general indexing,
+C> but each wave field is in sequential 'IBM order',
+C> i.e. with zonal wavenumber as the slower index.
+C>
+C> The transforms are all multiprocessed over stations.
+C>
+C> Transform several fields at a time to improve vectorization.
+C>
+C> Subprogram can be called from a multiprocessing environment.
+C>
+C> @param IROMB spectral domain shape
+c> (0 for triangular, 1 for rhomboidal)
+C> @param MAXWV spectral truncation
+C> @param KMAX number of fields to transform.
+C> @param NMAX number of station points to return
+C> @param KWSKIP skip number between wave fields
+c> (defaults to (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0)
+C> @param KGSKIP skip number between station point sets
+c> (defaults to NMAX IF KGSKIP=0)
+C> @param NRSKIP skip number between station lats and lons
+c> (defaults to 1 if NRSKIP=0)
+C> @param NGSKIP skip number between station points
+c> (defaults to 1 if NGSKIP=0)
+C> @param RLAT station latitudes in degrees
+C> @param RLON station longitudes in degrees
+C> @param WAVED wave divergence fields
+C> @param WAVEZ wave vorticity fields
+C> @param UP station point u-wind sets
+C> @param VP station point v-wind sets
+C>
+C> @author IREDELL @date 96-02-29
+ SUBROUTINE SPTGPTV(IROMB,MAXWV,KMAX,NMAX,
+ & KWSKIP,KGSKIP,NRSKIP,NGSKIP,
+ & RLAT,RLON,WAVED,WAVEZ,UP,VP)
+
+ REAL RLAT(*),RLON(*),WAVED(*),WAVEZ(*),UP(*),VP(*)
+ REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1)
+ REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1)
+ INTEGER MP(2*KMAX)
+ REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,2*KMAX)
+ REAL WTOP(2*(MAXWV+1),2*KMAX)
+ REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),PLNTOP(MAXWV+1)
+ REAL F(2*MAXWV+3,2,2*KMAX)
+ REAL G(2*KMAX)
+ PARAMETER(PI=3.14159265358979)
+
+C CALCULATE PRELIMINARY CONSTANTS
+ CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP)
+ MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+ MXTOP=MAXWV+1
+ MDIM=2*MX+1
+ IDIM=2*MAXWV+3
+ KW=KWSKIP
+ KG=KGSKIP
+ NR=NRSKIP
+ NG=NGSKIP
+ IF(KW.EQ.0) KW=2*MX
+ IF(KG.EQ.0) KG=NMAX
+ IF(NR.EQ.0) NR=1
+ IF(NG.EQ.0) NG=1
+ MP=1
+
+C CALCULATE SPECTRAL WINDS
+C$OMP PARALLEL DO PRIVATE(KWS)
+ DO K=1,KMAX
+ KWS=(K-1)*KW
+ CALL SPDZ2UV(IROMB,MAXWV,ENN1,ELONN1,EON,EONTOP,
+ & WAVED(KWS+1),WAVEZ(KWS+1),
+ & W(1,K),W(1,KMAX+K),WTOP(1,K),WTOP(1,KMAX+K))
+ ENDDO
+
+C CALCULATE STATION FIELDS
+C$OMP PARALLEL DO PRIVATE(KU,KV,RADLAT,SLAT1,CLAT1)
+C$OMP& PRIVATE(PLN,PLNTOP,F,G,NK)
+ DO N=1,NMAX
+ RADLAT=PI/180*RLAT((N-1)*NR+1)
+ IF(RLAT((N-1)*NR+1).GE.89.9995) THEN
+ SLAT1=1.
+ CLAT1=0.
+ ELSEIF(RLAT((N-1)*NR+1).LE.-89.9995) THEN
+ SLAT1=-1.
+ CLAT1=0.
+ ELSE
+ SLAT1=SIN(RADLAT)
+ CLAT1=COS(RADLAT)
+ ENDIF
+ CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP,
+ & PLN,PLNTOP)
+ CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,MDIM,2*MXTOP,2*KMAX,
+ & CLAT1,PLN,PLNTOP,MP,W,WTOP,F)
+ CALL SPFFTPT(MAXWV,1,2*MAXWV+3,1,2*KMAX,RLON((N-1)*NR+1),F,G)
+ DO K=1,KMAX
+ KU=K
+ KV=K+KMAX
+ NK=(N-1)*NG+(K-1)*KG+1
+ UP(NK)=G(KU)
+ VP(NK)=G(KV)
+ ENDDO
+ ENDDO
+
+ END
diff --git a/src/sptgptvd.f b/src/sptgptvd.f
new file mode 100644
index 00000000..14b35e42
--- /dev/null
+++ b/src/sptgptvd.f
@@ -0,0 +1,160 @@
+C> @file
+C> @brief Transform spectral vector to station points.
+C>
+C> ### Program History Log
+C> Date | Programmer | Comments
+C> -----|------------|---------
+C> 96-02-29 | Iredell | Initial.
+C> 1998-12-15 | Iredell | Openmp directives inserted.
+C> 1999-08-18 | Iredell | Openmp directive typo fixed.
+C>
+C> @author Iredell @date 96-02-29
+
+C> This subprogram performs a spherical transform
+C> from spectral coefficients of divergences and curls
+C> to specified sets of station point vectors and their
+C> gradients on the globe.
+C>
+C>
+C> DP=(D(UP)/DLON+D(VP*CLAT)/DLAT)/(R*CLAT)
+C> ZP=(D(VP)/DLON-D(UP*CLAT)/DLAT)/(R*CLAT)
+C> UXP=D(UP*CLAT)/DLON/(R*CLAT)
+C> VXP=D(VP*CLAT)/DLON/(R*CLAT)
+C> UYP=D(UP*CLAT)/DLAT/R
+C> VYP=D(VP*CLAT)/DLAT/R
+C>
+C>
+C> The wave-space can be either triangular or rhomboidal.
+C>
+C> The wave and point fields may have general indexing,
+C> but each wave field is in sequential 'IBM order',
+C> i.e. with zonal wavenumber as the slower index.
+C>
+C> The transforms are all multiprocessed over stations.
+C>
+C> Transform several fields at a time to improve vectorization.
+C>
+C> Subprogram can be called from a multiprocessing environment.
+C>
+C> @param IROMB spectral domain shape
+C> (0 for triangular, 1 for rhomboidal)
+C> @param MAXWV spectral truncation
+C> @param KMAX number of fields to transform.
+C> @param NMAX number of station points to return
+C> @param KWSKIP skip number between wave fields
+C> (defaults to (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0)
+C> @param KGSKIP skip number between station point sets
+C> (defaults to NMAX if KGSKIP=0)
+C> @param NRSKIP skip number between station lats and lons
+C> (defaults to 1 if NRSKIP=0)
+C> @param NGSKIP skip number between station points
+C> (defaults to 1 if NGSKIP=0)
+C> @param RLAT station latitudes in degrees
+C> @param RLON station longitudes in degrees
+C> @param WAVED wave divergence fields
+C> @param WAVEZ wave vorticity fields
+C> @param DP station point divergence sets
+C> @param ZP station point vorticity sets
+C> @param UP station point u-wind sets
+C> @param VP station point v-wind sets
+C> @param UXP station point u-wind x-gradient sets
+C> @param VXP station point v-wind x-gradient sets
+C> @param UYP station point u-wind y-gradient sets
+C> @param VYP station point v-wind y-gradient sets
+C>
+C> @author Iredell @date 96-02-29
+ SUBROUTINE SPTGPTVD(IROMB,MAXWV,KMAX,NMAX,
+ & KWSKIP,KGSKIP,NRSKIP,NGSKIP,
+ & RLAT,RLON,WAVED,WAVEZ,
+ & DP,ZP,UP,VP,UXP,VXP,UYP,VYP)
+
+ REAL RLAT(*),RLON(*),WAVED(*),WAVEZ(*)
+ REAL DP(*),ZP(*),UP(*),VP(*),UXP(*),VXP(*),UYP(*),VYP(*)
+ REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1)
+ REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1)
+ INTEGER MP(4*KMAX)
+ REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2,4*KMAX)
+ REAL WTOP(2*(MAXWV+1),4*KMAX)
+ REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),PLNTOP(MAXWV+1)
+ REAL F(2*MAXWV+2,2,6*KMAX),G(6*KMAX)
+ PARAMETER(PI=3.14159265358979)
+
+C CALCULATE PRELIMINARY CONSTANTS
+ CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP)
+ MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+ MXTOP=MAXWV+1
+ MDIM=2*MX
+ IDIM=2*MAXWV+2
+ KW=KWSKIP
+ KG=KGSKIP
+ NR=NRSKIP
+ NG=NGSKIP
+ IF(KW.EQ.0) KW=2*MX
+ IF(KG.EQ.0) KG=NMAX
+ IF(NR.EQ.0) NR=1
+ IF(NG.EQ.0) NG=1
+ MP(1:2*KMAX)=0
+ MP(2*KMAX+1:4*KMAX)=1
+
+C CALCULATE SPECTRAL WINDS
+C$OMP PARALLEL DO PRIVATE(KWS,KD,KZ,KU,KV)
+ DO K=1,KMAX
+ KWS=(K-1)*KW
+ KD=0*KMAX+K
+ KZ=1*KMAX+K
+ KU=2*KMAX+K
+ KV=3*KMAX+K
+ DO I=1,2*MX
+ W(I,KD)=WAVED(KWS+I)
+ W(I,KZ)=WAVEZ(KWS+I)
+ ENDDO
+ DO I=1,2*MXTOP
+ WTOP(I,KD)=0
+ WTOP(I,KZ)=0
+ ENDDO
+ CALL SPDZ2UV(IROMB,MAXWV,ENN1,ELONN1,EON,EONTOP,
+ & WAVED(KWS+1),WAVEZ(KWS+1),
+ & W(1,KU),W(1,KV),WTOP(1,KU),WTOP(1,KV))
+ ENDDO
+
+C CALCULATE STATION FIELDS
+C$OMP PARALLEL DO PRIVATE(KD,KZ,KU,KV,KUX,KVX,SLAT1,CLAT1)
+C$OMP& PRIVATE(PLN,PLNTOP,F,G,NK)
+ DO N=1,NMAX
+ KU=2*KMAX+1
+ KUX=4*KMAX+1
+ IF(ABS(RLAT((N-1)*NR+1)).GE.89.9995) THEN
+ SLAT1=SIGN(1.,RLAT((N-1)*NR+1))
+ CLAT1=0.
+ ELSE
+ SLAT1=SIN(PI/180*RLAT((N-1)*NR+1))
+ CLAT1=COS(PI/180*RLAT((N-1)*NR+1))
+ ENDIF
+ CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP,
+ & PLN,PLNTOP)
+ CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,MDIM,2*MXTOP,4*KMAX,
+ & CLAT1,PLN,PLNTOP,MP,W,WTOP,F)
+ CALL SPGRADX(MAXWV,IDIM,2*KMAX,MP(2*KMAX+1),CLAT1,
+ & F(1,1,2*KMAX+1),F(1,1,4*KMAX+1))
+ CALL SPFFTPT(MAXWV,1,IDIM,1,6*KMAX,RLON((N-1)*NR+1),F,G)
+ DO K=1,KMAX
+ KD=0*KMAX+K
+ KZ=1*KMAX+K
+ KU=2*KMAX+K
+ KV=3*KMAX+K
+ KUX=4*KMAX+K
+ KVX=5*KMAX+K
+ NK=(N-1)*NG+(K-1)*KG+1
+ DP(NK)=G(KD)
+ ZP(NK)=G(KZ)
+ UP(NK)=G(KU)
+ VP(NK)=G(KV)
+ UXP(NK)=G(KUX)
+ VXP(NK)=G(KVX)
+ UYP(NK)=G(KVX)-CLAT1*G(KZ)
+ VYP(NK)=CLAT1*G(KD)-G(KUX)
+ ENDDO
+ ENDDO
+ END
diff --git a/src/sptran.f b/src/sptran.f
new file mode 100644
index 00000000..1d52a458
--- /dev/null
+++ b/src/sptran.f
@@ -0,0 +1,122 @@
+C> @file
+C> @brief Perform a scalar spherical transform.
+C>
+C> ### Program History Log
+C> Date | Programmer | Comments
+C> -----|------------|---------
+C> 96-02-29 | IREDELL | Initial
+C> 1998-12-15 | IREDELL | Generic fft used, openmp directives inserted
+C>
+C> @author IREDELL @date 96-02-29
+
+C> This subprogram performs a spherical transform between spectral
+C> coefficients of scalar quantities and fields on a global
+C> cylindrical grid.
+C>
+C> The wave-space can be either triangular or
+C> rhomboidal.
+C>
+C> The grid-space can be either an equally-spaced grid
+C> (with or without pole points) or a Gaussian grid.
+C>
+C> The wave and grid fields may have general indexing,
+C> but each wave field is in sequential 'IBM order',
+C> i.e. with zonal wavenumber as the slower index.
+C>
+C> Transforms are done in latitude pairs for efficiency;
+C> thus grid arrays for each hemisphere must be passed.
+C> If so requested, just a subset of the latitude pairs
+C> may be transformed in each invocation of the subprogram.
+C>
+C> The transforms are all multiprocessed over latitude except
+C> the transform from Fourier to spectral is multiprocessed
+C> over zonal wavenumber to ensure reproducibility.
+C>
+C> Transform several fields at a time to improve vectorization.
+C> Subprogram can be called from a multiprocessing environment.
+C>
+C> Minimum grid dimensions for unaliased transforms to spectral:
+C> DIMENSION |LINEAR |QUADRATIC
+C> ----------------------- |--------- |-------------
+C> IMAX | 2*MAXWV+2 | 3*MAXWV/2*2+2
+C> JMAX (IDRT=4,IROMB=0) | 1*MAXWV+1 | 3*MAXWV/2+1
+C> JMAX (IDRT=4,IROMB=1) | 2*MAXWV+1 | 5*MAXWV/2+1
+C> JMAX (IDRT=0,IROMB=0) | 2*MAXWV+3 | 3*MAXWV/2*2+3
+C> JMAX (IDRT=0,IROMB=1) | 4*MAXWV+3 | 5*MAXWV/2*2+3
+C> JMAX (IDRT=256,IROMB=0) | 2*MAXWV+1 | 3*MAXWV/2*2+1
+C> JMAX (IDRT=256,IROMB=1) | 4*MAXWV+1 | 5*MAXWV/2*2+1
+C>
+C> @param IROMB spectral domain shape
+c> (0 for triangular, 1 for rhomboidal)
+C> @param MAXWV spectral truncation
+C> @param IDRT grid identifier
+C> - IDRT=4 for Gaussian grid,
+C> - IDRT=0 for equally-spaced grid including poles,
+C> - IDRT=256 for equally-spaced grid excluding poles
+C> @param IMAX even number of longitudes.
+C> @param JMAX number of latitudes.
+C> @param KMAX number of fields to transform.
+C> @param IPRIME longitude index for the prime meridian.
+C> (defaults to 1 if IPRIME=0)
+C> @param ISKIP skip number between longitudes
+C> (defaults to 1 if ISKIP=0)
+C> @param JNSKIP skip number between n.h. latitudes from north
+C> (defaults to imax if JNSKIP=0)
+C> @param JSSKIP skip number between s.h. latitudes from south
+c> (defaults to -imax if JSSKIP=0)
+C> @param KWSKIP skip number between wave fields
+c> (defaults to (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0)
+C> @param KGSKIP skip number between grid fields
+c> (defaults to IMAX*JMAX IF KGSKIP=0)
+C> @param JBEG latitude index (from pole) to begin transform
+c> (defaults to 1 if JBEG=0)
+C> (if JBEG=0 and IDIR<0, wave is zeroed before transform)
+C> @param JEND latitude index (from pole) to end transform
+c> (defaults to (JMAX+1)/2 IF JEND=0)
+C> @param JCPU number of cpus over which to multiprocess
+C> @param[out] WAVE wave fields if IDIR>0
+C> @param[out] gridn n.h. grid fields (starting at jbeg) if IDIR<0
+C> @param[out] grids s.h. grid fields (starting at jbeg) if IDIR<0
+C> @param IDIR transform flag
+C> (idir>0 for wave to grid, idir<0 for grid to wave)
+C>
+C> @author IREDELL @date 96-02-29
+ SUBROUTINE SPTRAN(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX,
+ & IPRIME,ISKIP,JNSKIP,JSSKIP,KWSKIP,KGSKIP,
+ & JBEG,JEND,JCPU,
+ & WAVE,GRIDN,GRIDS,IDIR)
+
+ REAL WAVE(*),GRIDN(*),GRIDS(*)
+
+ MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+ IP=IPRIME
+ IS=ISKIP
+ JN=JNSKIP
+ JS=JSSKIP
+ KW=KWSKIP
+ KG=KGSKIP
+ JB=JBEG
+ JE=JEND
+ JC=JCPU
+ IF(IP.EQ.0) IP=1
+ IF(IS.EQ.0) IS=1
+ IF(JN.EQ.0) JN=IMAX
+ IF(JS.EQ.0) JS=-JN
+ IF(KW.EQ.0) KW=2*MX
+ IF(KG.EQ.0) KG=IMAX*JMAX
+ IF(JB.EQ.0) JB=1
+ IF(JE.EQ.0) JE=(JMAX+1)/2
+ IF(JC.EQ.0) JC=NCPUS()
+
+ IF(IDIR.LT.0.AND.JBEG.EQ.0) THEN
+ DO K=1,KMAX
+ KWS=(K-1)*KW
+ WAVE(KWS+1:KWS+2*MX)=0
+ ENDDO
+ ENDIF
+
+ CALL SPTRANF(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX,
+ & IP,IS,JN,JS,KW,KG,JB,JE,JC,
+ & WAVE,GRIDN,GRIDS,IDIR)
+
+ END
diff --git a/src/sptrand.f b/src/sptrand.f
new file mode 100644
index 00000000..f26cb877
--- /dev/null
+++ b/src/sptrand.f
@@ -0,0 +1,150 @@
+C> @file
+C> @brief Perform a gradient spherical transform.
+C>
+C> ### Program History Log
+C> Date | Programmer | Comments
+C> -----|------------|---------
+C> 96-02-29 | IREDELL | Initial
+C> 1998-12-15 | IREDELL | openmp directives inserted
+C>
+C> @author Iredell @date 96-02-29
+
+C> This subprogram performs a spherical transform
+C> between spectral coefficients of scalar fields
+C> and their means and gradients on a global cylindrical grid.
+C>
+C> The wave-space can be either triangular or rhomboidal.
+C>
+C> The grid-space can be either an equally-spaced grid
+C> (with or without pole points) or a Gaussian grid.
+C>
+C> The wave and grid fields may have general indexing,
+C> but each wave field is in sequential 'IBM order',
+C> i.e. with zonal wavenumber as the slower index.
+C>
+C> Transforms are done in latitude pairs for efficiency;
+C> thus grid arrays for each hemisphere must be passed.
+C> if so requested, just a subset of the latitude pairs
+C> may be transformed in each invocation of the subprogram.
+C>
+C> The transforms are all multiprocessed over latitude except
+C> the transform from Fourier to spectral is multiprocessed
+C> over zonal wavenumber to ensure reproducibility.
+C>
+C> Transform several fields at a time to improve vectorization.
+C>
+C> Subprogram can be called from a multiprocessing environment.
+C>
+C> Minimum grid dimensions for unaliased transforms to spectral:
+C> DIMENSION |LINEAR |QUADRATIC
+C> ----------------------- |--------- |-------------
+C> IMAX |2*MAXWV+2 |3*MAXWV/2*2+2
+C> JMAX (IDRT=4,IROMB=0) |1*MAXWV+1 |3*MAXWV/2+1
+C> JMAX (IDRT=4,IROMB=1) |2*MAXWV+1 |5*MAXWV/2+1
+C> JMAX (IDRT=0,IROMB=0) |2*MAXWV+3 |3*MAXWV/2*2+3
+C> JMAX (IDRT=0,IROMB=1) |4*MAXWV+3 |5*MAXWV/2*2+3
+C> JMAX (IDRT=256,IROMB=0) |2*MAXWV+1 |3*MAXWV/2*2+1
+C> JMAX (IDRT=256,IROMB=1) |4*MAXWV+1 |5*MAXWV/2*2+1
+C>
+C> @param IROMB spectral domain shape
+C> (0 for triangular, 1 for rhomboidal)
+C> @param MAXWV spectral truncation
+C> @param IDRT grid identifier
+C> - IDRT=4 for Gaussian grid
+C> - IDRT=0 for equally-spaced grid including poles
+C> - IDRT=256 for equally-spaced grid excluding poles
+C> @param IMAX even number of longitudes.
+C> @param JMAX number of latitudes.
+C> @param KMAX number of fields to transform.
+C> @param IPRIME longitude index for the prime meridian.
+C> (defaults to 1 if IPRIME=0)
+C> @param ISKIP skip number between longitudes
+C> (defaults to 1 if ISKIP=0)
+C> @param JNSKIP skip number between n.h. latitudes from north
+C> (defaults to IMAX if JNSKIP=0)
+C> @param JSSKIP skip number between s.h. latitudes from south
+C> (defaults to -IMAX if JSSKIP=0)
+C> @param KWSKIP skip number between wave fields
+C> (defaults to (MAXWV+1)*((IROMB+1)*MAXWV+2) if KWSKIP=0)
+C> @param KGSKIP skip number between grid fields
+C> (defaults to IMAX*JMAX if KGSKIP=0)
+C> @param JBEG latitude index (from pole) to begin transform
+C> (defaults to 1 if JBEG=0). If JBEG=0 and IDIR<0, wave is zeroed before transform.
+C> @param JEND latitude index (from pole) to end transform
+C> (defaults to (JMAX+1)/2 if JEND=0)
+C> @param JCPU number of cpus over which to multiprocess
+C> @param[out] WAVE wave fields if IDIR>0
+C> @param[out] GRIDMN global means if IDIR<0
+C> @param[out] GRIDXN n.h. x-gradients (starting at JBEG) if IDIR<0
+C> @param[out] GRIDXS s.h. x-gradients (starting at JBEG) if IDIR<0
+C> [GRIDX=(D(WAVE)/DLAM)/(CLAT*RERTH)]
+C> @param[out] GRIDYN n.h. y-gradients (starting at JBEG) if IDIR<0
+C> @param[out] GRIDYS s.h. y-gradients (starting at JBEG) if IDIR<0
+C> [GRIDY=(D(WAVE)/DPHI)/RERTH]
+C> @param IDIR transform flag
+C> (IDIR>0 for wave to grid, IDIR<0 for grid to wave)
+C>
+C> @author Iredell @date 96-02-29
+ SUBROUTINE SPTRAND(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX,
+ & IPRIME,ISKIP,JNSKIP,JSSKIP,KWSKIP,KGSKIP,
+ & JBEG,JEND,JCPU,
+ & WAVE,GRIDMN,GRIDXN,GRIDXS,GRIDYN,GRIDYS,IDIR)
+
+ REAL WAVE(*),GRIDMN(KMAX),GRIDXN(*),GRIDXS(*),GRIDYN(*),GRIDYS(*)
+ REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1)
+ REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1)
+ REAL WD((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX)
+ REAL WZ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX)
+
+C SET PARAMETERS
+ CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP)
+ MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+ MDIM=2*MX+1
+ KW=KWSKIP
+ IF(KW.EQ.0) KW=2*MX
+
+C TRANSFORM WAVE TO GRID
+ IF(IDIR.GT.0) THEN
+C$OMP PARALLEL DO PRIVATE(KWS)
+ DO K=1,KMAX
+ KWS=(K-1)*KW
+ GRIDMN(K)=WAVE(KWS+1)/SQRT(2.)
+ CALL SPLAPLAC(IROMB,MAXWV,ENN1,WAVE(KWS+1),WD(1,K),1)
+ WZ(1:2*MX,K)=0.
+ ENDDO
+ CALL SPTRANV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX,
+ & IPRIME,ISKIP,JNSKIP,JSSKIP,MDIM,KGSKIP,
+ & JBEG,JEND,JCPU,
+ & WD,WZ,GRIDXN,GRIDXS,GRIDYN,GRIDYS,IDIR)
+
+C TRANSFORM GRID TO WAVE
+ ELSE
+C$OMP PARALLEL DO
+ DO K=1,KMAX
+ WD(1:2*MX,K)=0.
+ WZ(1:2*MX,K)=0.
+ ENDDO
+ CALL SPTRANV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX,
+ & IPRIME,ISKIP,JNSKIP,JSSKIP,MDIM,KGSKIP,
+ & JBEG,JEND,JCPU,
+ & WD,WZ,GRIDXN,GRIDXS,GRIDYN,GRIDYS,IDIR)
+ IF(JBEG.EQ.0) THEN
+C$OMP PARALLEL DO PRIVATE(KWS)
+ DO K=1,KMAX
+ KWS=(K-1)*KW
+ CALL SPLAPLAC(IROMB,MAXWV,ENN1,WAVE(KWS+1),WD(1,K),-1)
+ WAVE(KWS+1)=GRIDMN(K)*SQRT(2.)
+ ENDDO
+ ELSE
+C$OMP PARALLEL DO PRIVATE(KWS)
+ DO K=1,KMAX
+ KWS=(K-1)*KW
+ CALL SPLAPLAC(IROMB,MAXWV,ENN1,WZ(1,K),WD(1,K),-1)
+ WAVE(KWS+1:KWS+2*MX)=WAVE(KWS+1:KWS+2*MX)+WZ(1:2*MX,K)
+ WAVE(KWS+1)=GRIDMN(K)*SQRT(2.)
+ ENDDO
+ ENDIF
+ ENDIF
+ END
diff --git a/src/sptranf.f b/src/sptranf.f
new file mode 100644
index 00000000..18f5ca32
--- /dev/null
+++ b/src/sptranf.f
@@ -0,0 +1,161 @@
+C> @file
+C> @brief Perform a scalar spherical transform
+C>
+C> ### Program History Log
+C> Date | Programmer | Comments
+C> -----|------------|---------
+C> 96-02-29 | Iredell | Initial.
+C> 1998-12-15 | Iredell | Generic fft used, openmp directives inserted
+C> 2013-01-16 | Iredell, Mirvis | Fixing afft negative sharing effect
+C>
+C> @author Iredell @date 96-02-29
+
+C> This subprogram performs a spherical transform between spectral
+C> coefficients of scalar quantities and fields on a global
+C> cylindrical grid.
+C>
+C> The wave-space can be either triangular or
+C> rhomboidal. The grid-space can be either an equally-spaced grid
+C> (with or without pole points) or a Gaussian grid.
+C>
+C> The wave and grid fields may have general indexing,
+C> but each wave field is in sequential 'ibm order',
+C> i.e. with zonal wavenumber as the slower index.
+C>
+C> Transforms are done in latitude pairs for efficiency;
+C> thus grid arrays for each hemisphere must be passed.
+C>
+C> If so requested, just a subset of the latitude pairs
+C> may be transformed in each invocation of the subprogram.
+C> The transforms are all multiprocessed over latitude except
+C> the transform from fourier to spectral is multiprocessed
+C> over zonal wavenumber to ensure reproducibility.
+C>
+C> Transform several fields at a time to improve vectorization.
+C> Subprogram can be called from a multiprocessing environment.
+C>
+C> Minimum grid dimensions for unaliased transforms to spectral:
+C> DIMENSION |LINEAR |QUADRATIC
+C> ----------------------- |--------- |-------------
+C> IMAX | 2*MAXWV+2 | 3*MAXWV/2*2+2
+C> JMAX (IDRT=4,IROMB=0) | 1*MAXWV+1 | 3*MAXWV/2+1
+C> JMAX (IDRT=4,IROMB=1) | 2*MAXWV+1 | 5*MAXWV/2+1
+C> JMAX (IDRT=0,IROMB=0) | 2*MAXWV+3 | 3*MAXWV/2*2+3
+C> JMAX (IDRT=0,IROMB=1) | 4*MAXWV+3 | 5*MAXWV/2*2+3
+C> JMAX (IDRT=256,IROMB=0) | 2*MAXWV+1 | 3*MAXWV/2*2+1
+C> JMAX (IDRT=256,IROMB=1) | 4*MAXWV+1 | 5*MAXWV/2*2+1
+C>
+C> @param IROMB spectral domain shape
+c> (0 for triangular, 1 for rhomboidal)
+C> @param MAXWV spectral truncation
+C> @param IDRT grid identifier
+C> - IDRT=4 for Gaussian grid,
+C> - IDRT=0 for equally-spaced grid including poles
+C> - IDRT=256 for equally-spaced grid excluding poles
+C> @param IMAX even number of longitudes.
+C> @param JMAX number of latitudes.
+C> @param KMAX number of fields to transform.
+C> @param IP longitude index for the prime meridian
+C> @param IS skip number between longitudes
+C> @param JN skip number between n.h. latitudes from north
+C> @param JS skip number between s.h. latitudes from south
+C> @param KW skip number between wave fields
+C> @param KG skip number between grid fields
+C> @param JB latitude index (from pole) to begin transform
+C> @param JE latitude index (from pole) to end transform
+C> @param JC number of cpus over which to multiprocess
+C> @param[out] WAVE wave fields if IDIR>0
+C> @param[out] GRIDN n.h. grid fields (starting at JB) if IDIR<0
+C> @param[out] GRIDS s.h. grid fields (starting at JB) if IDIR<0
+C> @param IDIR transform flag
+C> (IDIR>0 for wave to grid, IDIR<0 for grid to wave)
+C>
+C> @author Iredell @date 96-02-29
+ SUBROUTINE SPTRANF(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX,
+ & IP,IS,JN,JS,KW,KG,JB,JE,JC,
+ & WAVE,GRIDN,GRIDS,IDIR)
+
+ REAL WAVE(*),GRIDN(*),GRIDS(*)
+ REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1)
+ REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1)
+ REAL(8) AFFT(50000+4*IMAX), AFFT_TMP(50000+4*IMAX)
+ REAL CLAT(JB:JE),SLAT(JB:JE),WLAT(JB:JE)
+ REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2,JB:JE)
+ REAL PLNTOP(MAXWV+1,JB:JE)
+ REAL WTOP(2*(MAXWV+1))
+ REAL G(IMAX,2)
+! write(0,*) 'sptranf top'
+
+C SET PARAMETERS
+ MP=0
+ CALL SPTRANF0(IROMB,MAXWV,IDRT,IMAX,JMAX,JB,JE,
+ & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP,
+ & AFFT,CLAT,SLAT,WLAT,PLN,PLNTOP)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C TRANSFORM WAVE TO GRID
+ IF(IDIR.GT.0) THEN
+C$OMP PARALLEL DO PRIVATE(AFFT_TMP,KWS,WTOP,G,IJKN,IJKS)
+ DO K=1,KMAX
+ AFFT_TMP=AFFT
+ KWS=(K-1)*KW
+ WTOP=0
+ DO J=JB,JE
+ CALL SPTRANF1(IROMB,MAXWV,IDRT,IMAX,JMAX,J,J,
+ & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP,
+ & AFFT_TMP,CLAT(J),SLAT(J),WLAT(J),
+ & PLN(1,J),PLNTOP(1,J),MP,
+ & WAVE(KWS+1),WTOP,G,IDIR)
+ IF(IP.EQ.1.AND.IS.EQ.1) THEN
+ DO I=1,IMAX
+ IJKN=I+(J-JB)*JN+(K-1)*KG
+ IJKS=I+(J-JB)*JS+(K-1)*KG
+ GRIDN(IJKN)=G(I,1)
+ GRIDS(IJKS)=G(I,2)
+ ENDDO
+ ELSE
+ DO I=1,IMAX
+ IJKN=MOD(I+IP-2,IMAX)*IS+(J-JB)*JN+(K-1)*KG+1
+ IJKS=MOD(I+IP-2,IMAX)*IS+(J-JB)*JS+(K-1)*KG+1
+ GRIDN(IJKN)=G(I,1)
+ GRIDS(IJKS)=G(I,2)
+ ENDDO
+ ENDIF
+ ENDDO
+ ENDDO
+
+C TRANSFORM GRID TO WAVE
+ ELSE
+C$OMP PARALLEL DO PRIVATE(AFFT_TMP,KWS,WTOP,G,IJKN,IJKS)
+ DO K=1,KMAX
+ AFFT_TMP=AFFT
+ KWS=(K-1)*KW
+ WTOP=0
+ DO J=JB,JE
+ IF(WLAT(J).GT.0.) THEN
+ IF(IP.EQ.1.AND.IS.EQ.1) THEN
+ DO I=1,IMAX
+ IJKN=I+(J-JB)*JN+(K-1)*KG
+ IJKS=I+(J-JB)*JS+(K-1)*KG
+ G(I,1)=GRIDN(IJKN)
+ G(I,2)=GRIDS(IJKS)
+ ENDDO
+ ELSE
+ DO I=1,IMAX
+ IJKN=MOD(I+IP-2,IMAX)*IS+(J-JB)*JN+(K-1)*KG+1
+ IJKS=MOD(I+IP-2,IMAX)*IS+(J-JB)*JS+(K-1)*KG+1
+ G(I,1)=GRIDN(IJKN)
+ G(I,2)=GRIDS(IJKS)
+ ENDDO
+ ENDIF
+ CALL SPTRANF1(IROMB,MAXWV,IDRT,IMAX,JMAX,J,J,
+ & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP,
+ & AFFT_TMP,CLAT(J),SLAT(J),WLAT(J),
+ & PLN(1,J),PLNTOP(1,J),MP,
+ & WAVE(KWS+1),WTOP,G,IDIR)
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+ END
diff --git a/src/sptranf0.f b/src/sptranf0.f
new file mode 100644
index 00000000..4feb90df
--- /dev/null
+++ b/src/sptranf0.f
@@ -0,0 +1,64 @@
+C> @file
+C> @brief Sptranf spectral initialization.
+C> @author IREDELL @date 96-02-29
+
+C> This subprogram performs an initialization for
+C> subprogram sptranf(). Use this subprogram outside
+C> the sptranf() family context at your own risk.
+C>
+C> @param IROMB spectral domain shape
+c> (0 for triangular, 1 for rhomboidal)
+C> @param MAXWV spectral truncation
+C> @param IDRT grid identifier
+C> - IDRT=4 for Gaussian grid,
+C> - IDRT=0 for equally-spaced grid including poles,
+C> - IDRT=256 for equally-spaced grid excluding poles
+C> @param IMAX even number of longitudes
+C> @param JMAX number of latitudes
+C> @param JB latitude index (from pole) to begin transform
+C> @param JE latitude index (from pole) to end transform
+C> @param EPS
+C> @param EPSTOP
+C> @param ENN1
+C> @param ELONN1
+C> @param EON
+C> @param EONTOP
+C> @param AFFT auxiliary array if IDIR=0
+C> @param CLAT cosines of latitude
+C> @param SLAT sines of latitude
+C> @param WLAT Gaussian weights
+C> @param PLN Legendre polynomials
+C> @param PLNTOP Legendre polynomial over top
+C>
+C> @author IREDELL @date 96-02-29
+ SUBROUTINE SPTRANF0(IROMB,MAXWV,IDRT,IMAX,JMAX,JB,JE,
+ & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP,
+ & AFFT,CLAT,SLAT,WLAT,PLN,PLNTOP)
+
+ REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1)
+ REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1)
+ REAL(8) AFFT(50000+4*IMAX)
+ REAL CLAT(JB:JE),SLAT(JB:JE),WLAT(JB:JE)
+ REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2,JB:JE)
+ REAL PLNTOP(MAXWV+1,JB:JE)
+ REAL SLATX(JMAX),WLATX(JMAX)
+
+ CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP)
+ CALL SPFFTE(IMAX,(IMAX+2)/2,IMAX,2,0.,0.,0,AFFT)
+ CALL SPLAT(IDRT,JMAX,SLATX,WLATX)
+ JHE=(JMAX+1)/2
+ IF(JHE.GT.JMAX/2) WLATX(JHE)=WLATX(JHE)/2
+ DO J=JB,JE
+ CLAT(J)=SQRT(1.-SLATX(J)**2)
+ SLAT(J)=SLATX(J)
+ WLAT(J)=WLATX(J)
+ ENDDO
+C$OMP PARALLEL DO
+ DO J=JB,JE
+ CALL SPLEGEND(IROMB,MAXWV,SLAT(J),CLAT(J),EPS,EPSTOP,
+ & PLN(1,J),PLNTOP(1,J))
+ ENDDO
+
+ END
diff --git a/src/sptranf1.f b/src/sptranf1.f
new file mode 100644
index 00000000..37a07bde
--- /dev/null
+++ b/src/sptranf1.f
@@ -0,0 +1,76 @@
+C> @file
+C> @brief Sptranf spectral transform.
+C> @author Iredell @date 96-02-29
+
+C> This subprogram performs an single latitude transform for
+C> subprogram sptranf(). Use this subprogram outside
+C> the sptranf() family context at your own risk.
+C>
+C> @param IROMB spectral domain shape
+C> (0 for triangular, 1 for rhomboidal)
+C> @param MAXWV spectral truncation
+C> @param IDRT grid identifier
+C> - IDRT=4 for Gaussian grid,
+C> - IDRT=0 for equally-spaced grid including poles,
+C> - IDRT=256 for equally-spaced grid excluding poles
+C> @param IMAX even number of longitudes
+C> @param JMAX number of latitudes
+C> @param JB latitude index (from pole) to begin transform
+C> @param JE latitude index (from pole) to end transform
+C> @param EPS
+C> @param EPSTOP
+C> @param ENN1
+C> @param ELONN1
+C> @param EON
+C> @param EONTOP
+C> @param CLAT cosines of latitude
+C> @param SLAT sines of latitude
+C> @param WLAT Gaussian weights
+C> @param AFFT auxiliary array if IDIR=0
+C> @param PLN Legendre polynomials
+C> @param PLNTOP Legendre polynomial over top
+C> @param MP identifier (0 for scalar, 1 for vector)
+C> @param[out] W wave field if IDIR>0
+C> @param[out] WTOP wave field over top if IDIR>0
+C> @param[out] G grid field if IDIR<0
+C> @param IDIR transform flag
+C> (IDIR>0 for wave to grid, IDIR<0 for grid to wave)
+C>
+C> @author Iredell @date 96-02-29
+ SUBROUTINE SPTRANF1(IROMB,MAXWV,IDRT,IMAX,JMAX,JB,JE,
+ & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP,
+ & AFFT,CLAT,SLAT,WLAT,PLN,PLNTOP,MP,
+ & W,WTOP,G,IDIR)
+
+ REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1)
+ REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1)
+ REAL(8) AFFT(50000+4*IMAX)
+ REAL CLAT(JB:JE),SLAT(JB:JE),WLAT(JB:JE)
+ REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2,JB:JE)
+ REAL PLNTOP(MAXWV+1,JB:JE)
+ REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2))
+ REAL WTOP(2*(MAXWV+1))
+ REAL G(IMAX,2,JB:JE)
+ REAL F(IMAX+2,2)
+
+ KW=(MAXWV+1)*((IROMB+1)*MAXWV+2)
+ KWTOP=2*(MAXWV+1)
+ IF(IDIR.GT.0) THEN
+ DO J=JB,JE
+ CALL SPSYNTH(IROMB,MAXWV,IMAX,IMAX+2,KW,KWTOP,1,
+ & CLAT(J),PLN(1,J),PLNTOP(1,J),MP,
+ & W,WTOP,F)
+ CALL SPFFTE(IMAX,(IMAX+2)/2,IMAX,2,F,G(1,1,J),+1,AFFT)
+ ENDDO
+ ELSE
+ DO J=JB,JE
+ CALL SPFFTE(IMAX,(IMAX+2)/2,IMAX,2,F,G(1,1,J),-1,AFFT)
+ CALL SPANALY(IROMB,MAXWV,IMAX,IMAX+2,KW,KWTOP,1,
+ & WLAT(J),CLAT(J),PLN(1,J),PLNTOP(1,J),MP,
+ & F,W,WTOP)
+ ENDDO
+ ENDIF
+
+ END
diff --git a/src/sptranfv.f b/src/sptranfv.f
new file mode 100644
index 00000000..26e9d4ef
--- /dev/null
+++ b/src/sptranfv.f
@@ -0,0 +1,196 @@
+C> @file
+C> @brief Perform a vector spherical transform
+C>
+C> ### Program History Log
+C> Date | Programmer | Comments
+C> -----|------------|---------
+C> 96-02-29 | Iredell | Initial.
+C> 1998-12-15 | Iredell | Generic fft used, openmp directives inserted
+C> 2013-01-16 | Iredell & MIRVIS | Fixing afft negative sharing effect during omp loops
+C>
+C> @author Iredell @date 96-02-29
+
+C> This subprogram performs a spherical transform
+C> between spectral coefficients of divergences and curls
+C> and vector fields on a global cylindrical grid.
+C>
+C> The wave-space can be either triangular or rhomboidal.
+C>
+C> The grid-space can be either an equally-spaced grid
+C> (with or without pole points) or a Gaussian grid.
+C>
+C> The wave and grid fields may have general indexing,
+C> but each wave field is in sequential 'ibm order',
+C> i.e. with zonal wavenumber as the slower index.
+C>
+C> Transforms are done in latitude pairs for efficiency;
+C> thus grid arrays for each hemisphere must be passed.
+C> if so requested, just a subset of the latitude pairs
+C> may be transformed in each invocation of the subprogram.
+C>
+C> The transforms are all multiprocessed over latitude except
+C> the transform from fourier to spectral is multiprocessed
+C> over zonal wavenumber to ensure reproducibility.
+C>
+C> Transform several fields at a time to improve vectorization.
+C> subprogram can be called from a multiprocessing environment.
+C>
+C> Minimum grid dimensions for unaliased transforms to spectral:
+C> DIMENSION |LINEAR |QUADRATIC
+C> ----------------------- |--------- |-------------
+C> IMAX |2*MAXWV+2 |3*MAXWV/2*2+2
+C> JMAX (IDRT=4,IROMB=0) |1*MAXWV+1 |3*MAXWV/2+1
+C> JMAX (IDRT=4,IROMB=1) |2*MAXWV+1 |5*MAXWV/2+1
+C> JMAX (IDRT=0,IROMB=0) |2*MAXWV+3 |3*MAXWV/2*2+3
+C> JMAX (IDRT=0,IROMB=1) |4*MAXWV+3 |5*MAXWV/2*2+3
+C> JMAX (IDRT=256,IROMB=0) |2*MAXWV+1 |3*MAXWV/2*2+1
+C> JMAX (IDRT=256,IROMB=1) |4*MAXWV+1 |5*MAXWV/2*2+1
+C>
+C> @param IROMB spectral domain shape
+C> (0 for triangular, 1 for rhomboidal)
+C> @param MAXWV spectral truncation
+C> @param IDRT grid identifier
+C> - IDRT=4 for Gaussian grid
+C> - IDRT=0 for equally-spaced grid including poles
+C> - IDRT=256 for equally-spaced grid excluding poles
+C> @param IMAX even number of longitudes.
+C> @param JMAX number of latitudes.
+C> @param KMAX number of fields to transform.
+C> @param IP longitude index for the prime meridian
+C> @param IS skip number between longitudes
+C> @param JN skip number between n.h. latitudes from north
+C> @param JS skip number between s.h. latitudes from south
+C> @param KW skip number between wave fields
+C> @param KG skip number between grid fields
+C> @param JB latitude index (from pole) to begin transform
+C> @param JE latitude index (from pole) to end transform
+C> @param JC number of cpus over which to multiprocess
+C> @param[out] WAVED wave divergence fields if IDIR>0
+C> [WAVED=(D(GRIDU)/DLAM+D(CLAT*GRIDV)/DPHI)/(CLAT*RERTH)]
+C> @param[out] WAVEZ wave vorticity fields if IDIR>0
+C> [WAVEZ=(D(GRIDV)/DLAM-D(CLAT*GRIDU)/DPHI)/(CLAT*RERTH)]
+C> @param[out] GRIDUN N.H. grid u-winds (starting at jb) if IDIR<0
+C> @param[out] GRIDUS S.H. grid u-winds (starting at jb) if IDIR<0
+C> @param[out] GRIDVN N.H. grid v-winds (starting at jb) if IDIR<0
+C> @param[out] GRIDVS S.H. grid v-winds (starting at jb) if IDIR<0
+C> @param IDIR transform flag
+C> (IDIR>0 for wave to grid, IDIR<0 for grid to wave).
+C>
+C> @author Iredell @date 96-02-29
+ SUBROUTINE SPTRANFV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX,
+ & IP,IS,JN,JS,KW,KG,JB,JE,JC,
+ & WAVED,WAVEZ,GRIDUN,GRIDUS,GRIDVN,GRIDVS,IDIR)
+
+ REAL WAVED(*),WAVEZ(*),GRIDUN(*),GRIDUS(*),GRIDVN(*),GRIDVS(*)
+ REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1)
+ REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1)
+ REAL(8) AFFT(50000+4*IMAX), AFFT_TMP(50000+4*IMAX)
+ REAL CLAT(JB:JE),SLAT(JB:JE),WLAT(JB:JE)
+ REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2,JB:JE)
+ REAL PLNTOP(MAXWV+1,JB:JE)
+ INTEGER MP(2)
+ REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2,2)
+ REAL WTOP(2*(MAXWV+1),2)
+ REAL G(IMAX,2,2)
+ REAL WINC((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2,2)
+
+C SET PARAMETERS
+ MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+ MP=1
+ CALL SPTRANF0(IROMB,MAXWV,IDRT,IMAX,JMAX,JB,JE,
+ & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP,
+ & AFFT,CLAT,SLAT,WLAT,PLN,PLNTOP)
+
+C TRANSFORM WAVE TO GRID
+ IF(IDIR.GT.0) THEN
+C$OMP PARALLEL DO PRIVATE(AFFT_TMP,KWS,W,WTOP,G,IJKN,IJKS)
+ DO K=1,KMAX
+ AFFT_TMP=AFFT
+ KWS=(K-1)*KW
+ CALL SPDZ2UV(IROMB,MAXWV,ENN1,ELONN1,EON,EONTOP,
+ & WAVED(KWS+1),WAVEZ(KWS+1),
+ & W(1,1),W(1,2),WTOP(1,1),WTOP(1,2))
+ DO J=JB,JE
+ CALL SPTRANF1(IROMB,MAXWV,IDRT,IMAX,JMAX,J,J,
+ & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP,
+ & AFFT_TMP,CLAT(J),SLAT(J),WLAT(J),
+ & PLN(1,J),PLNTOP(1,J),MP,
+ & W(1,1),WTOP(1,1),G(1,1,1),IDIR)
+ CALL SPTRANF1(IROMB,MAXWV,IDRT,IMAX,JMAX,J,J,
+ & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP,
+ & AFFT_TMP,CLAT(J),SLAT(J),WLAT(J),
+ & PLN(1,J),PLNTOP(1,J),MP,
+ & W(1,2),WTOP(1,2),G(1,1,2),IDIR)
+ IF(IP.EQ.1.AND.IS.EQ.1) THEN
+ DO I=1,IMAX
+ IJKN=I+(J-JB)*JN+(K-1)*KG
+ IJKS=I+(J-JB)*JS+(K-1)*KG
+ GRIDUN(IJKN)=G(I,1,1)
+ GRIDUS(IJKS)=G(I,2,1)
+ GRIDVN(IJKN)=G(I,1,2)
+ GRIDVS(IJKS)=G(I,2,2)
+ ENDDO
+ ELSE
+ DO I=1,IMAX
+ IJKN=MOD(I+IP-2,IMAX)*IS+(J-JB)*JN+(K-1)*KG+1
+ IJKS=MOD(I+IP-2,IMAX)*IS+(J-JB)*JS+(K-1)*KG+1
+ GRIDUN(IJKN)=G(I,1,1)
+ GRIDUS(IJKS)=G(I,2,1)
+ GRIDVN(IJKN)=G(I,1,2)
+ GRIDVS(IJKS)=G(I,2,2)
+ ENDDO
+ ENDIF
+ ENDDO
+ ENDDO
+
+C TRANSFORM GRID TO WAVE
+ ELSE
+C$OMP PARALLEL DO PRIVATE(AFFT_TMP,KWS,W,WTOP,G,IJKN,IJKS,WINC)
+ DO K=1,KMAX
+ AFFT_TMP=AFFT
+ KWS=(K-1)*KW
+ W=0
+ WTOP=0
+ DO J=JB,JE
+ IF(WLAT(J).GT.0.) THEN
+ IF(IP.EQ.1.AND.IS.EQ.1) THEN
+ DO I=1,IMAX
+ IJKN=I+(J-JB)*JN+(K-1)*KG
+ IJKS=I+(J-JB)*JS+(K-1)*KG
+ G(I,1,1)=GRIDUN(IJKN)/CLAT(J)**2
+ G(I,2,1)=GRIDUS(IJKS)/CLAT(J)**2
+ G(I,1,2)=GRIDVN(IJKN)/CLAT(J)**2
+ G(I,2,2)=GRIDVS(IJKS)/CLAT(J)**2
+ ENDDO
+ ELSE
+ DO I=1,IMAX
+ IJKN=MOD(I+IP-2,IMAX)*IS+(J-JB)*JN+(K-1)*KG+1
+ IJKS=MOD(I+IP-2,IMAX)*IS+(J-JB)*JS+(K-1)*KG+1
+ G(I,1,1)=GRIDUN(IJKN)/CLAT(J)**2
+ G(I,2,1)=GRIDUS(IJKS)/CLAT(J)**2
+ G(I,1,2)=GRIDVN(IJKN)/CLAT(J)**2
+ G(I,2,2)=GRIDVS(IJKS)/CLAT(J)**2
+ ENDDO
+ ENDIF
+ CALL SPTRANF1(IROMB,MAXWV,IDRT,IMAX,JMAX,J,J,
+ & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP,
+ & AFFT_TMP,CLAT(J),SLAT(J),WLAT(J),
+ & PLN(1,J),PLNTOP(1,J),MP,
+ & W(1,1),WTOP(1,1),G(1,1,1),IDIR)
+ CALL SPTRANF1(IROMB,MAXWV,IDRT,IMAX,JMAX,J,J,
+ & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP,
+ & AFFT_TMP,CLAT(J),SLAT(J),WLAT(J),
+ & PLN(1,J),PLNTOP(1,J),MP,
+ & W(1,2),WTOP(1,2),G(1,1,2),IDIR)
+ ENDIF
+ ENDDO
+ CALL SPUV2DZ(IROMB,MAXWV,ENN1,ELONN1,EON,EONTOP,
+ & W(1,1),W(1,2),WTOP(1,1),WTOP(1,2),
+ & WINC(1,1),WINC(1,2))
+ WAVED(KWS+1:KWS+2*MX)=WAVED(KWS+1:KWS+2*MX)+WINC(1:2*MX,1)
+ WAVEZ(KWS+1:KWS+2*MX)=WAVEZ(KWS+1:KWS+2*MX)+WINC(1:2*MX,2)
+ ENDDO
+ ENDIF
+ END
diff --git a/src/sptranv.f b/src/sptranv.f
new file mode 100644
index 00000000..a8018dc1
--- /dev/null
+++ b/src/sptranv.f
@@ -0,0 +1,126 @@
+C> @file
+C> @brief Perform a vector spherical transform.
+C>
+C> ### Program History Log
+C> Date | Programmer | Comments
+C> -----|------------|---------
+C> 96-02-29 | IREDELL | Initial.
+C> 1998-12-15 | IREDELL | Generic fft used, openmp directives inserted
+C>
+C> @author IREDELL @date 96-02-29
+
+C> This subprogram performs a spherical transform
+C> between spectral coefficients of divergences and curls
+C> and vector fields on a global cylindrical grid.
+C>
+C> The wave-space can be either triangular or rhomboidal.
+C>
+C> The grid-space can be either an equally-spaced grid
+C> (with or without pole points) or a Gaussian grid.
+C> the wave and grid fields may have general indexing,
+C> but each wave field is in sequential 'ibm order',
+C> i.e. with zonal wavenumber as the slower index.
+C>
+C> Transforms are done in latitude pairs for efficiency;
+C> thus grid arrays for each hemisphere must be passed.
+C> If so requested, just a subset of the latitude pairs
+C> may be transformed in each invocation of the subprogram.
+C>
+C> The transforms are all multiprocessed over latitude except
+C> the transform from fourier to spectral is multiprocessed
+C> over zonal wavenumber to ensure reproducibility.
+C>
+C> Transform several fields at a time to improve vectorization.
+C> Subprogram can be called from a multiprocessing environment.
+C>
+C> Minimum grid dimensions for unaliased transforms to spectral:
+C> DIMENSION |LINEAR |QUADRATIC
+C> ----------------------- |--------- |-------------
+C> IMAX |2*MAXWV+2 |3*MAXWV/2*2+2
+C> JMAX (IDRT=4,IROMB=0) |1*MAXWV+1 |3*MAXWV/2+1
+C> JMAX (IDRT=4,IROMB=1) |2*MAXWV+1 |5*MAXWV/2+1
+C> JMAX (IDRT=0,IROMB=0) |2*MAXWV+3 |3*MAXWV/2*2+3
+C> JMAX (IDRT=0,IROMB=1) |4*MAXWV+3 |5*MAXWV/2*2+3
+C> JMAX (IDRT=256,IROMB=0) |2*MAXWV+1 |3*MAXWV/2*2+1
+C> JMAX (IDRT=256,IROMB=1) |4*MAXWV+1 |5*MAXWV/2*2+1
+C>
+C> @param IROMB SPECTRAL DOMAIN SHAPE
+C> (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL)
+C> @param MAXWV SPECTRAL TRUNCATION
+C> @param IDRT GRID IDENTIFIER
+C> - IDRT=4 FOR GAUSSIAN GRID,
+C> - IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES,
+C> - IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES
+C> @param IMAX EVEN NUMBER OF LONGITUDES.
+C> @param JMAX NUMBER OF LATITUDES.
+C> @param KMAX NUMBER OF FIELDS TO TRANSFORM.
+C> @param IPRIME LONGITUDE INDEX FOR THE PRIME MERIDIAN.
+C> (DEFAULTS TO 1 IF IPRIME=0)
+C> @param ISKIP SKIP NUMBER BETWEEN LONGITUDES
+C> (DEFAULTS TO 1 IF ISKIP=0)
+C> @param JNSKIP SKIP NUMBER BETWEEN N.H. LATITUDES FROM NORTH
+C> (DEFAULTS TO IMAX IF JNSKIP=0)
+C> @param JSSKIP SKIP NUMBER BETWEEN S.H. LATITUDES FROM SOUTH
+C> (DEFAULTS TO -IMAX IF JSSKIP=0)
+C> @param KWSKIP SKIP NUMBER BETWEEN WAVE FIELDS
+C> (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0)
+C> @param KGSKIP SKIP NUMBER BETWEEN GRID FIELDS
+C> (DEFAULTS TO IMAX*JMAX IF KGSKIP=0)
+C> @param JBEG LATITUDE INDEX (FROM POLE) TO BEGIN TRANSFORM
+C> - DEFAULTS TO 1 IF JBEG=0
+C> - IF JBEG=0 AND IDIR<0, WAVE IS ZEROED BEFORE TRANSFORM
+C> @param JEND LATITUDE INDEX (FROM POLE) TO END TRANSFORM
+C> (DEFAULTS TO (JMAX+1)/2 IF JEND=0)
+C> @param JCPU NUMBER OF CPUS OVER WHICH TO MULTIPROCESS
+C> @param[out] WAVED (*) WAVE DIVERGENCE FIELDS IF IDIR>0
+C> [WAVED=(D(GRIDU)/DLAM+D(CLAT*GRIDV)/DPHI)/(CLAT*RERTH)]
+C> @param[out] WAVEZ (*) WAVE VORTICITY FIELDS IF IDIR>0
+C> [WAVEZ=(D(GRIDV)/DLAM-D(CLAT*GRIDU)/DPHI)/(CLAT*RERTH)]
+C> @param[out] GRIDUN N.H. GRID U-WINDS (STARTING AT JBEG) IF IDIR<0
+C> @param[out] GRIDUS S.H. GRID U-WINDS (STARTING AT JBEG) IF IDIR<0
+C> @param[out] GRIDVN N.H. GRID V-WINDS (STARTING AT JBEG) IF IDIR<0
+C> @param[out] GRIDVS S.H. GRID V-WINDS (STARTING AT JBEG) IF IDIR<0
+C> @param IDIR TRANSFORM FLAG
+C> - IDIR>0 FOR WAVE TO GRID,
+C> - IDIR<0 FOR GRID TO WAVE
+C>
+ SUBROUTINE SPTRANV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX,
+ & IPRIME,ISKIP,JNSKIP,JSSKIP,KWSKIP,KGSKIP,
+ & JBEG,JEND,JCPU,
+ & WAVED,WAVEZ,GRIDUN,GRIDUS,GRIDVN,GRIDVS,IDIR)
+
+ REAL WAVED(*),WAVEZ(*),GRIDUN(*),GRIDUS(*),GRIDVN(*),GRIDVS(*)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+ IP=IPRIME
+ IS=ISKIP
+ JN=JNSKIP
+ JS=JSSKIP
+ KW=KWSKIP
+ KG=KGSKIP
+ JB=JBEG
+ JE=JEND
+ JC=JCPU
+ IF(IP.EQ.0) IP=1
+ IF(IS.EQ.0) IS=1
+ IF(JN.EQ.0) JN=IMAX
+ IF(JS.EQ.0) JS=-JN
+ IF(KW.EQ.0) KW=2*MX
+ IF(KG.EQ.0) KG=IMAX*JMAX
+ IF(JB.EQ.0) JB=1
+ IF(JE.EQ.0) JE=(JMAX+1)/2
+ IF(JC.EQ.0) JC=NCPUS()
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ IF(IDIR.LT.0.AND.JBEG.EQ.0) THEN
+ DO K=1,KMAX
+ KWS=(K-1)*KW
+ WAVED(KWS+1:KWS+2*MX)=0
+ WAVEZ(KWS+1:KWS+2*MX)=0
+ ENDDO
+ ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ CALL SPTRANFV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX,
+ & IP,IS,JN,JS,KW,KG,JB,JE,JC,
+ & WAVED,WAVEZ,GRIDUN,GRIDUS,GRIDVN,GRIDVS,IDIR)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ END
diff --git a/src/sptrun.f b/src/sptrun.f
new file mode 100644
index 00000000..41c113f5
--- /dev/null
+++ b/src/sptrun.f
@@ -0,0 +1,85 @@
+C> @file
+C> @brief Truncate gridded scalar fields
+C> @author IREDELL @date 96-02-29
+
+C> This subprogram spectrally truncates scalar fields on a global
+C> cylindrical grid, returning the fields to a possibly different
+C> global cylindrical grid. The wave-space can be either triangular
+C> or rhomboidal. either grid-space can be either an equally-spaced
+C> grid (with or without pole points) or a Gaussian grid. the grid
+C> fields may have general indexing. the transforms are all
+C> multiprocessed. Transform several fields at a time to improve
+C> vectorization. Subprogram can be called from a multiprocessing
+C> environment.
+C>
+C> Remarks: Minimum grid dimensions for unaliased transforms to spectral:
+C> Dimension | Linear | Quadratic
+C> ----------------------- | --------- | -------------
+C> IMAX | 2*MAXWV+2 | 3*MAXWV/2*2+2
+C> JMAX (IDRT=4,IROMB=0) | 1*MAXWV+1 | 3*MAXWV/2+1
+C> JMAX (IDRT=4,IROMB=1) | 2*MAXWV+1 | 5*MAXWV/2+1
+C> JMAX (IDRT=0,IROMB=0) | 2*MAXWV+3 | 3*MAXWV/2*2+3
+C> JMAX (IDRT=0,IROMB=1) | 4*MAXWV+3 | 5*MAXWV/2*2+3
+C> JMAX (IDRT=256,IROMB=0) | 2*MAXWV+1 | 3*MAXWV/2*2+1
+C> JMAX (IDRT=256,IROMB=1) | 4*MAXWV+1 | 5*MAXWV/2*2+1
+C>
+C> @param IROMB Spectral domain shape (0 for triangular, 1 for rhomboidal)
+C> @param MAXWV Spectral truncation
+C> @param IDRTI Input grid identifier
+C> - IDRTI=4 for Gaussian grid
+C> - IDRTI=0 for equally-spaced grid including poles
+C> - IDRTI=256 for equally-spaced grid excluding poles
+C> @param IMAXI Even number of input longitudes
+C> @param JMAXI Number of input latitudes
+C> @param IDRTO Output grid identifier
+C> - IDRTO=4 for Gaussian grid
+C> - IDRTO=0 for equally-spaced grid including poles
+C> - IDRTO=256 for equally-spaced grid excluding poles
+C> @param IMAXO Even number of output longitudes
+C> @param JMAXO Number of output latitudes
+C> @param KMAX Number of fields to transform
+C> @param IPRIME Input longitude index for the prime meridian.
+C> - Defaults to 1 if IPRIME=0
+C> - Output longitude index for prime meridian assumed 1
+C> @param ISKIPI Skip number between input longitudes (defaults to 1 if ISKIPI=0)
+C> @param JSKIPI Skip number between input latitudes from south (defaults to -IMAXI if JSKIPI=0)
+C> @param KSKIPI Skip number between input grid fields (defaults to IMAXI*JMAXI if KSKIPI=0)
+C> @param ISKIPO Skip number between output longitudes (defaults to 1 if ISKIPO=0)
+C> @param JSKIPO Skip number between output latitudes from south (defaults to -IMAXO if JSKIPO=0)
+C> @param KSKIPO Skip number between output grid fields (defaults to IMAXO*JMAXO if KSKIPO=0)
+C> @param JCPU Number of CPUs over which to multiprocess (defaults to environment NCPUS if JCPU=0)
+C> @param GRIDI Input grid fields
+C> @param GRIDO Output grid fields (may overlay input fields if grid shape is appropriate)
+C>
+C> @author IREDELL @date 96-02-29
+ SUBROUTINE SPTRUN(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,IDRTO,IMAXO,JMAXO,
+ & KMAX,IPRIME,ISKIPI,JSKIPI,KSKIPI,
+ & ISKIPO,JSKIPO,KSKIPO,JCPU,GRIDI,GRIDO)
+ REAL GRIDI(*),GRIDO(*)
+ REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C TRANSFORM INPUT GRID TO WAVE
+ JC=JCPU
+ IF(JC.EQ.0) JC=NCPUS()
+ MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+ MDIM=2*MX+1
+ JN=-JSKIPI
+ IF(JN.EQ.0) JN=IMAXI
+ JS=-JN
+ INP=(JMAXI-1)*MAX(0,-JN)+1
+ ISP=(JMAXI-1)*MAX(0,-JS)+1
+ CALL SPTRAN(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,
+ & IPRIME,ISKIPI,JN,JS,MDIM,KSKIPI,0,0,JC,
+ & W,GRIDI(INP),GRIDI(ISP),-1)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C TRANSFORM WAVE TO OUTPUT
+ JN=-JSKIPO
+ IF(JN.EQ.0) JN=IMAXO
+ JS=-JN
+ INP=(JMAXO-1)*MAX(0,-JN)+1
+ ISP=(JMAXO-1)*MAX(0,-JS)+1
+ CALL SPTRAN(IROMB,MAXWV,IDRTO,IMAXO,JMAXO,KMAX,
+ & 0,ISKIPO,JN,JS,MDIM,KSKIPO,0,0,JC,
+ & W,GRIDO(INP),GRIDO(ISP),1)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ END
diff --git a/src/sptrund.f b/src/sptrund.f
new file mode 100644
index 00000000..dc1c157b
--- /dev/null
+++ b/src/sptrund.f
@@ -0,0 +1,105 @@
+C> @file
+C>
+C> Spectrally truncate to gradients
+C> @author IREDELL @date 96-02-29
+
+C> THIS SUBPROGRAM SPECTRALLY TRUNCATES SCALAR FIELDS
+C> ON A GLOBAL CYLINDRICAL GRID, RETURNING THEIR MEANS AND
+C> GRADIENTS TO A POSSIBLY DIFFERENT GLOBAL CYLINDRICAL GRID.
+C> THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL.
+C> EITHER GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID
+C> (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID.
+C> THE GRID FIELDS MAY HAVE GENERAL INDEXING.
+C> THE TRANSFORMS ARE ALL MULTIPROCESSED.
+C> OVER ZONAL WAVENUMBER TO ENSURE REPRODUCIBILITY.
+C> TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION.
+C> SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
+C>
+C> @param IROMB - INTEGER SPECTRAL DOMAIN SHAPE
+C> (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL)
+C> @param MAXWV - INTEGER SPECTRAL TRUNCATION
+C> @param IDRTI - INTEGER INPUT GRID IDENTIFIER
+C> (IDRTI=4 FOR GAUSSIAN GRID,
+C> IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES,
+C> IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES)
+C> @param IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES.
+C> @param JMAXI - INTEGER NUMBER OF INPUT LATITUDES.
+C> @param IDRTO - INTEGER OUTPUT GRID IDENTIFIER
+C> (IDRTO=4 FOR GAUSSIAN GRID,
+C> IDRTO=0 FOR EQUALLY-SPACED GRID INCLUDING POLES,
+C> IDRTO=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES)
+C> @param IMAXO - INTEGER EVEN NUMBER OF OUTPUT LONGITUDES.
+C> @param JMAXO - INTEGER NUMBER OF OUTPUT LATITUDES.
+C> @param KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM.
+C> @param IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN.
+C> (DEFAULTS TO 1 IF IPRIME=0)
+C> (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.)
+C> @param ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES
+C> (DEFAULTS TO 1 IF ISKIPI=0)
+C> @param JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH
+C> (DEFAULTS TO -IMAXI IF JSKIPI=0)
+C> @param KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS
+C> (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0)
+C> @param ISKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT LONGITUDES
+C> (DEFAULTS TO 1 IF ISKIPO=0)
+C> @param JSKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT LATITUDES FROM SOUTH
+C> (DEFAULTS TO -IMAXO IF JSKIPO=0)
+C> @param KSKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT GRID FIELDS
+C> (DEFAULTS TO IMAXO*JMAXO IF KSKIPO=0)
+C> @param JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS
+C> (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0)
+C> @param GRID - REAL (*) INPUT GRID FIELDS
+C> @param GRIDMN - REAL (KMAX) OUTPUT GLOBAL MEANS
+C> @param GRIDX - REAL (*) OUTPUT X-GRADIENTS
+C> @param GRIDY - REAL (*) OUTPUT Y-GRADIENTS
+C>
+C> SUBPROGRAMS CALLED:
+C> - SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM
+C> - SPTRAND PERFORM A GRADIENT SPHERICAL TRANSFORM
+C> - NCPUS GETS ENVIRONMENT NUMBER OF CPUS
+C>
+C> REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL:
+C> DIMENSION |LINEAR |QUADRATIC
+C> ----------------------- |--------- |-------------
+C> IMAX |2*MAXWV+2 |3*MAXWV/2*2+2
+C> JMAX (IDRT=4,IROMB=0) |1*MAXWV+1 |3*MAXWV/2+1
+C> JMAX (IDRT=4,IROMB=1) |2*MAXWV+1 |5*MAXWV/2+1
+C> JMAX (IDRT=0,IROMB=0) |2*MAXWV+3 |3*MAXWV/2*2+3
+C> JMAX (IDRT=0,IROMB=1) |4*MAXWV+3 |5*MAXWV/2*2+3
+C> JMAX (IDRT=256,IROMB=0) |2*MAXWV+1 |3*MAXWV/2*2+1
+C> JMAX (IDRT=256,IROMB=1) |4*MAXWV+1 |5*MAXWV/2*2+1
+ SUBROUTINE SPTRUND(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,
+ & IDRTO,IMAXO,JMAXO,KMAX,
+ & IPRIME,ISKIPI,JSKIPI,KSKIPI,
+ & ISKIPO,JSKIPO,KSKIPO,JCPU,GRID,
+ & GRIDMN,GRIDX,GRIDY)
+
+ REAL GRID(*),GRIDX(*),GRIDY(*)
+ REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C TRANSFORM INPUT GRID TO WAVE
+ JC=JCPU
+ IF(JC.EQ.0) JC=NCPUS()
+ MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+ MDIM=2*MX+1
+ JN=-JSKIPI
+ IF(JN.EQ.0) JN=IMAXI
+ JS=-JN
+ INP=(JMAXI-1)*MAX(0,-JN)+1
+ ISP=(JMAXI-1)*MAX(0,-JS)+1
+ CALL SPTRAN(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,
+ & IPRIME,ISKIPI,JN,JS,MDIM,KSKIPI,0,0,JC,
+ & W,GRID(INP),GRID(ISP),-1)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C TRANSFORM WAVE TO OUTPUT GRADIENTS
+ JN=-JSKIPO
+ IF(JN.EQ.0) JN=IMAXO
+ JS=-JN
+ INP=(JMAXO-1)*MAX(0,-JN)+1
+ ISP=(JMAXO-1)*MAX(0,-JS)+1
+ CALL SPTRAND(IROMB,MAXWV,IDRTO,IMAXO,JMAXO,KMAX,
+ & 0,ISKIPO,JN,JS,MDIM,KSKIPO,0,0,JC,
+ & W,GRIDMN,
+ & GRIDX(INP),GRIDX(ISP),GRIDY(INP),GRIDY(ISP),1)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ END
diff --git a/src/sptrung.f b/src/sptrung.f
new file mode 100644
index 00000000..0b5dc925
--- /dev/null
+++ b/src/sptrung.f
@@ -0,0 +1,90 @@
+C> @file
+C>
+C> Spectrally interpolate scalars to stations
+C> @author IREDELL @date 96-02-29
+
+C> This subprogram spectrally truncates scalar fields on a global
+C> cylindrical grid, returning the fields to specified sets of
+C> station points on the globe. The wave-space can be either
+C> triangular or rhomboidal. The grid-space can be either an
+C> equally-spaced grid (with or without pole points) or a Gaussian
+C> grid. The grid and point fields may have general indexing. The
+C> transforms are all multiprocessed. Transform several fields at a
+C> time to improve vectorization. Subprogram can be called from a
+C> multiprocessing environment.
+C>
+C> @param IROMB - INTEGER SPECTRAL DOMAIN SHAPE
+C> (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL)
+C> @param MAXWV - INTEGER SPECTRAL TRUNCATION
+C> @param IDRTI - INTEGER INPUT GRID IDENTIFIER
+C> (IDRTI=4 FOR GAUSSIAN GRID,
+C> IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES,
+C> IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES)
+C> @param IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES.
+C> @param JMAXI - INTEGER NUMBER OF INPUT LATITUDES.
+C> @param KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM.
+C> @param NMAX - INTEGER NUMBER OF STATION POINTS TO RETURN
+C> @param IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN.
+C> (DEFAULTS TO 1 IF IPRIME=0)
+C> (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.)
+C> @param ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES
+C> (DEFAULTS TO 1 IF ISKIPI=0)
+C> @param JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH
+C> (DEFAULTS TO -IMAXI IF JSKIPI=0)
+C> @param KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS
+C> (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0)
+C> @param KGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINT SETS
+C> (DEFAULTS TO NMAX IF KGSKIP=0)
+C> @param NRSKIP - INTEGER SKIP NUMBER BETWEEN STATION LATS AND LONS
+C> (DEFAULTS TO 1 IF NRSKIP=0)
+C> @param NGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINTS
+C> (DEFAULTS TO 1 IF NGSKIP=0)
+C> @param RLAT - REAL (*) STATION LATITUDES IN DEGREES
+C> @param RLON - REAL (*) STATION LONGITUDES IN DEGREES
+C> @param JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS
+C> (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0)
+C> @param GRIDI - REAL (*) INPUT GRID FIELDS
+C> @param[out] GP - REAL (*) STATION POINT SETS
+C>
+C> SUBPROGRAMS CALLED:
+C> - sptran() Perform a scalar spherical transform
+C> - sptgpt() Transform spectral scalar to station points
+C> - ncpus() Gets environment number of cpus
+C>
+C> Minimum grid dimensions for unaliased transforms to spectral:
+C> DIMENSION |LINEAR |QUADRATIC
+C> ----------------------- |--------- |-------------
+C> IMAX | 2*MAXWV+2 | 3*MAXWV/2*2+2
+C> JMAX (IDRT=4,IROMB=0) | 1*MAXWV+1 | 3*MAXWV/2+1
+C> JMAX (IDRT=4,IROMB=1) | 2*MAXWV+1 | 5*MAXWV/2+1
+C> JMAX (IDRT=0,IROMB=0) | 2*MAXWV+3 | 3*MAXWV/2*2+3
+C> JMAX (IDRT=0,IROMB=1) | 4*MAXWV+3 | 5*MAXWV/2*2+3
+C> JMAX (IDRT=256,IROMB=0) | 2*MAXWV+1 | 3*MAXWV/2*2+1
+C> JMAX (IDRT=256,IROMB=1) | 4*MAXWV+1 | 5*MAXWV/2*2+1
+C>
+ SUBROUTINE SPTRUNG(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,NMAX,
+ & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP,
+ & NRSKIP,NGSKIP,JCPU,RLAT,RLON,GRIDI,GP)
+
+ REAL RLAT(*),RLON(*),GRIDI(*),GP(*)
+ REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C TRANSFORM INPUT GRID TO WAVE
+ JC=JCPU
+ IF(JC.EQ.0) JC=NCPUS()
+ MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+ MDIM=2*MX+1
+ JN=-JSKIPI
+ IF(JN.EQ.0) JN=IMAXI
+ JS=-JN
+ INP=(JMAXI-1)*MAX(0,-JN)+1
+ ISP=(JMAXI-1)*MAX(0,-JS)+1
+ CALL SPTRAN(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,
+ & IPRIME,ISKIPI,JN,JS,MDIM,KSKIPI,0,0,JC,
+ & W,GRIDI(INP),GRIDI(ISP),-1)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C TRANSFORM WAVE TO OUTPUT
+ CALL SPTGPT(IROMB,MAXWV,KMAX,NMAX,MDIM,KGSKIP,NRSKIP,NGSKIP,
+ & RLAT,RLON,W,GP)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ END
diff --git a/src/sptrungv.f b/src/sptrungv.f
new file mode 100644
index 00000000..cf847b6a
--- /dev/null
+++ b/src/sptrungv.f
@@ -0,0 +1,141 @@
+C> @file
+C>
+C> Spectrally interpolate vectors to stations
+C> @author IREDELL @date 96-02-29
+
+C> THIS SUBPROGRAM SPECTRALLY TRUNCATES VECTORS FIELDS
+C> ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS
+C> TO SPECIFIED SETS OF STATION POINTS ON THE GLOBE.
+C> THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL.
+C> THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID
+C> (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID.
+C> THE GRID AND POINT FIELDS MAY HAVE GENERAL INDEXING.
+C> THE TRANSFORMS ARE ALL MULTIPROCESSED.
+C> TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION.
+C> SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
+C>
+C> PROGRAM HISTORY LOG:
+C> - 96-02-29 IREDELL
+C> - 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED
+C>
+C> @param IROMB - INTEGER SPECTRAL DOMAIN SHAPE
+C> (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL)
+C> @param MAXWV - INTEGER SPECTRAL TRUNCATION
+C> @param IDRTI - INTEGER INPUT GRID IDENTIFIER
+C> (IDRTI=4 FOR GAUSSIAN GRID,
+C> IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES,
+C> IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES)
+C> @param IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES.
+C> @param JMAXI - INTEGER NUMBER OF INPUT LATITUDES.
+C> @param KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM.
+C> @param NMAX - INTEGER NUMBER OF STATION POINTS TO RETURN
+C> @param IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN.
+C> (DEFAULTS TO 1 IF IPRIME=0)
+C> (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.)
+C> @param ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES
+C> (DEFAULTS TO 1 IF ISKIPI=0)
+C> @param JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH
+C> (DEFAULTS TO -IMAXI IF JSKIPI=0)
+C> @param KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS
+C> (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0)
+C> @param KGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINT SETS
+C> (DEFAULTS TO NMAX IF KGSKIP=0)
+C> @param NRSKIP - INTEGER SKIP NUMBER BETWEEN STATION LATS AND LONS
+C> (DEFAULTS TO 1 IF NRSKIP=0)
+C> @param NGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINTS
+C> (DEFAULTS TO 1 IF NGSKIP=0)
+C> @param RLAT - REAL (*) STATION LATITUDES IN DEGREES
+C> @param RLON - REAL (*) STATION LONGITUDES IN DEGREES
+C> @param JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS
+C> (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0)
+C> @param GRIDUI - REAL (*) INPUT GRID U-WINDS
+C> @param GRIDVI - REAL (*) INPUT GRID V-WINDS
+C> @param LUV - LOGICAL FLAG WHETHER TO RETURN WINDS
+C> @param LDZ - LOGICAL FLAG WHETHER TO RETURN DIVERGENCE AND VORTICITY
+C> @param LPS - LOGICAL FLAG WHETHER TO RETURN POTENTIAL AND STREAMFCN
+C> @param UP - REAL (*) STATION U-WINDS IF LUV
+C> @param VP - REAL (*) STATION V-WINDS IF LUV
+C> @param DP - REAL (*) STATION DIVERGENCES IF LDZ
+C> @param ZP - REAL (*) STATION VORTICITIES IF LDZ
+C> @param PP - REAL (*) STATION POTENTIALS IF LPS
+C> @param SP - REAL (*) STATION STREAMFCNS IF LPS
+C>
+C> SUBPROGRAMS CALLED:
+C> - SPWGET GET WAVE-SPACE CONSTANTS
+C> - SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE
+C> - SPTRANV PERFORM A VECTOR SPHERICAL TRANSFORM
+C> - SPTGPT TRANSFORM SPECTRAL SCALAR TO STATION POINTS
+C> - SPTGPTV TRANSFORM SPECTRAL VECTOR TO STATION POINTS
+C> - NCPUS GETS ENVIRONMENT NUMBER OF CPUS
+C>
+C> REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL:
+C> DIMENSION |LINEAR |QUADRATIC
+C> ----------------------- |--------- |-------------
+C> IMAX |2*MAXWV+2 |3*MAXWV/2*2+2
+C> JMAX (IDRT=4,IROMB=0) |1*MAXWV+1 |3*MAXWV/2+1
+C> JMAX (IDRT=4,IROMB=1) |2*MAXWV+1 |5*MAXWV/2+1
+C> JMAX (IDRT=0,IROMB=0) |2*MAXWV+3 |3*MAXWV/2*2+3
+C> JMAX (IDRT=0,IROMB=1) |4*MAXWV+3 |5*MAXWV/2*2+3
+C> JMAX (IDRT=256,IROMB=0) |2*MAXWV+1 |3*MAXWV/2*2+1
+C> JMAX (IDRT=256,IROMB=1) |4*MAXWV+1 |5*MAXWV/2*2+1
+ SUBROUTINE SPTRUNGV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,NMAX,
+ & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP,
+ & NRSKIP,NGSKIP,JCPU,RLAT,RLON,GRIDUI,GRIDVI,
+ & LUV,UP,VP,LDZ,DP,ZP,LPS,PP,SP)
+
+ LOGICAL LUV,LDZ,LPS
+ REAL RLAT(*),RLON(*),GRIDUI(*),GRIDVI(*)
+ REAL UP(*),VP(*),DP(*),ZP(*),PP(*),SP(*)
+ REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1)
+ REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1)
+ REAL WD((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX)
+ REAL WZ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C TRANSFORM INPUT GRID TO WAVE
+ JC=JCPU
+ IF(JC.EQ.0) JC=NCPUS()
+ MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+ MDIM=2*MX+1
+ JN=-JSKIPI
+ IF(JN.EQ.0) JN=IMAXI
+ JS=-JN
+ INP=(JMAXI-1)*MAX(0,-JN)+1
+ ISP=(JMAXI-1)*MAX(0,-JS)+1
+ CALL SPTRANV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,
+ & IPRIME,ISKIPI,JN,JS,MDIM,KSKIPI,0,0,JC,
+ & WD,WZ,
+ & GRIDUI(INP),GRIDUI(ISP),GRIDVI(INP),GRIDVI(ISP),-1)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C TRANSFORM WAVE TO OUTPUT WINDS
+ IF(LUV) THEN
+ CALL SPTGPTV(IROMB,MAXWV,KMAX,NMAX,MDIM,KGSKIP,NRSKIP,NGSKIP,
+ & RLAT,RLON,WD,WZ,UP,VP)
+ ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C TRANSFORM WAVE TO OUTPUT DIVERGENCE AND VORTICITY
+ IF(LDZ) THEN
+ CALL SPTGPT(IROMB,MAXWV,KMAX,NMAX,MDIM,KGSKIP,NRSKIP,NGSKIP,
+ & RLAT,RLON,WD,DP)
+ CALL SPTGPT(IROMB,MAXWV,KMAX,NMAX,MDIM,KGSKIP,NRSKIP,NGSKIP,
+ & RLAT,RLON,WZ,ZP)
+ ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C TRANSFORM WAVE TO OUTPUT POTENTIAL AND STREAMFUNCTION
+ IF(LPS) THEN
+ CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP)
+C$OMP PARALLEL DO
+ DO K=1,KMAX
+ CALL SPLAPLAC(IROMB,MAXWV,ENN1,WD(1,K),WD(1,K),-1)
+ CALL SPLAPLAC(IROMB,MAXWV,ENN1,WZ(1,K),WZ(1,K),-1)
+ WD(1:2,K)=0.
+ WZ(1:2,K)=0.
+ ENDDO
+ CALL SPTGPT(IROMB,MAXWV,KMAX,NMAX,MDIM,KGSKIP,NRSKIP,NGSKIP,
+ & RLAT,RLON,WD,PP)
+ CALL SPTGPT(IROMB,MAXWV,KMAX,NMAX,MDIM,KGSKIP,NRSKIP,NGSKIP,
+ & RLAT,RLON,WZ,SP)
+ ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ END
diff --git a/src/sptrunl.f b/src/sptrunl.f
new file mode 100644
index 00000000..d3fd42d8
--- /dev/null
+++ b/src/sptrunl.f
@@ -0,0 +1,115 @@
+C> @file
+C>
+C> Spectrally truncate to laplacian
+C> @author IREDELL @date 96-02-29
+
+C> THIS SUBPROGRAM SPECTRALLY TRUNCATES SCALAR FIELDS
+C> ON A GLOBAL CYLINDRICAL GRID, RETURNING THEIR LAPLACIAN
+C> OR INVERSE TO A POSSIBLY DIFFERENT GLOBAL CYLINDRICAL GRID.
+C> THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL.
+C> EITHER GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID
+C> (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID.
+C> THE GRID FIELDS MAY HAVE GENERAL INDEXING.
+C> THE TRANSFORMS ARE ALL MULTIPROCESSED.
+C> OVER ZONAL WAVENUMBER TO ENSURE REPRODUCIBILITY.
+C> TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION.
+C> SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
+C>
+C> PROGRAM HISTORY LOG:
+C> - 96-02-29 IREDELL
+C> - 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED
+C>
+C> @param IROMB - INTEGER SPECTRAL DOMAIN SHAPE
+C> (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL)
+C> @param MAXWV - INTEGER SPECTRAL TRUNCATION
+C> @param IDRTI - INTEGER INPUT GRID IDENTIFIER
+C> (IDRTI=4 FOR GAUSSIAN GRID,
+C> IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES,
+C> IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES)
+C> @param IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES.
+C> @param JMAXI - INTEGER NUMBER OF INPUT LATITUDES.
+C> @param IDRTO - INTEGER OUTPUT GRID IDENTIFIER
+C> (IDRTO=4 FOR GAUSSIAN GRID,
+C> IDRTO=0 FOR EQUALLY-SPACED GRID INCLUDING POLES,
+C> IDRTO=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES)
+C> @param IMAXO - INTEGER EVEN NUMBER OF OUTPUT LONGITUDES.
+C> @param JMAXO - INTEGER NUMBER OF OUTPUT LATITUDES.
+C> @param KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM.
+C> @param IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN.
+C> (DEFAULTS TO 1 IF IPRIME=0)
+C> (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.)
+C> @param ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES
+C> (DEFAULTS TO 1 IF ISKIPI=0)
+C> @param JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH
+C> (DEFAULTS TO -IMAXI IF JSKIPI=0)
+C> @param KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS
+C> (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0)
+C> @param ISKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT LONGITUDES
+C> (DEFAULTS TO 1 IF ISKIPO=0)
+C> @param JSKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT LATITUDES FROM SOUTH
+C> (DEFAULTS TO -IMAXO IF JSKIPO=0)
+C> @param KSKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT GRID FIELDS
+C> (DEFAULTS TO IMAXO*JMAXO IF KSKIPO=0)
+C> @param JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS
+C> (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0)
+C> @param IDIR - INTEGER FLAG
+C> IDIR > 0 TO TAKE LAPLACIAN
+C> IDIR < 0 TO TAKE INVERSE LAPLACIAN
+C> @param GRIDI - REAL (*) INPUT GRID FIELDS
+C> @param GRIDO - REAL (*) OUTPUT GRID FIELDS
+C> (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE)
+C>
+C> SUBPROGRAMS CALLED:
+C> - SPWGET GET WAVE-SPACE CONSTANTS
+C> - SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE
+C> - SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM
+C> - NCPUS GETS ENVIRONMENT NUMBER OF CPUS
+C>
+C> REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL:
+C> DIMENSION |LINEAR |QUADRATIC
+C> ----------------------- |--------- |-------------
+C> IMAX |2*MAXWV+2 |3*MAXWV/2*2+2
+C> JMAX (IDRT=4,IROMB=0) |1*MAXWV+1 |3*MAXWV/2+1
+C> JMAX (IDRT=4,IROMB=1) |2*MAXWV+1 |5*MAXWV/2+1
+C> JMAX (IDRT=0,IROMB=0) |2*MAXWV+3 |3*MAXWV/2*2+3
+C> JMAX (IDRT=0,IROMB=1) |4*MAXWV+3 |5*MAXWV/2*2+3
+C> JMAX (IDRT=256,IROMB=0) |2*MAXWV+1 |3*MAXWV/2*2+1
+C> JMAX (IDRT=256,IROMB=1) |4*MAXWV+1 |5*MAXWV/2*2+1
+ SUBROUTINE SPTRUNL(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,
+ & IDRTO,IMAXO,JMAXO,KMAX,
+ & IPRIME,ISKIPI,JSKIPI,KSKIPI,
+ & ISKIPO,JSKIPO,KSKIPO,JCPU,IDIR,GRIDI,GRIDO)
+
+ REAL GRIDI(*),GRIDO(*)
+ REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1)
+ REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1)
+ REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C TRANSFORM INPUT GRID TO WAVE
+ JC=JCPU
+ IF(JC.EQ.0) JC=NCPUS()
+ MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+ MDIM=2*MX+1
+ JN=-JSKIPI
+ IF(JN.EQ.0) JN=IMAXI
+ JS=-JN
+ INP=(JMAXI-1)*MAX(0,-JN)+1
+ ISP=(JMAXI-1)*MAX(0,-JS)+1
+ CALL SPTRAN(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,
+ & IPRIME,ISKIPI,JN,JS,MDIM,KSKIPI,0,0,JC,
+ & W,GRIDI(INP),GRIDI(ISP),-1)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C TAKE LAPLACIAN AND TRANSFORM WAVE TO OUTPUT GRID
+ CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP)
+C$OMP PARALLEL DO
+ DO K=1,KMAX
+ CALL SPLAPLAC(IROMB,MAXWV,ENN1,W(1,K),W(1,K),IDIR)
+ W(1:2,K)=0.
+ ENDDO
+ CALL SPTRAN(IROMB,MAXWV,IDRTO,IMAXO,JMAXO,KMAX,
+ & 0,ISKIPO,JN,JS,MDIM,KSKIPO,0,0,JC,
+ & W,GRIDO(INP),GRIDO(ISP),1)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ END
diff --git a/src/sptrunm.f b/src/sptrunm.f
new file mode 100644
index 00000000..0282abc2
--- /dev/null
+++ b/src/sptrunm.f
@@ -0,0 +1,101 @@
+C> @file
+C>
+C> Spectrally interpolate scalars to Mercator
+C> @author IREDELL @date 96-02-29
+
+C> This subprogram spectrally truncates scalar fields on a global
+C> cylindrical grid, returning the fields to a Mercator grid. The
+C> wave-space can be either triangular or rhomboidal. The grid-space
+C> can be either an equally-spaced grid (with or without pole
+C> points) or a Gaussian grid. The grid fields may have general
+C> indexing. The transforms are all multiprocessed. Transform
+C> several fields at a time to improve vectorization. Subprogram can
+C> be called from a multiprocessing environment.
+C>
+C>
+C> @param IROMB - INTEGER SPECTRAL DOMAIN SHAPE
+C> (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL)
+C> @param MAXWV - INTEGER SPECTRAL TRUNCATION
+C> @param IDRTI - INTEGER INPUT GRID IDENTIFIER
+C> (IDRTI=4 FOR GAUSSIAN GRID,
+C> IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES,
+C> IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES)
+C> @param IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES.
+C> @param JMAXI - INTEGER NUMBER OF INPUT LATITUDES.
+C> @param KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM.
+C> @param MI - INTEGER NUMBER OF POINTS IN THE FASTER ZONAL DIRECTION
+C> @param MJ - INTEGER NUMBER OF POINTS IN THE SLOWER MERID DIRECTION
+C> @param IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN.
+C> (DEFAULTS TO 1 IF IPRIME=0)
+C> (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.)
+C> @param ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES
+C> (DEFAULTS TO 1 IF ISKIPI=0)
+C> @param JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH
+C> (DEFAULTS TO -IMAXI IF JSKIPI=0)
+C> @param KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS
+C> (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0)
+C> @param KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS
+C> (DEFAULTS TO NPS*NPS IF KGSKIP=0)
+C> @param NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS
+C> (DEFAULTS TO 1 IF NISKIP=0)
+C> @param NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS
+C> (DEFAULTS TO NPS IF NJSKIP=0)
+C> @param JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS
+C> (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0)
+C> @param RLAT1 - REAL LATITUDE OF THE FIRST GRID POINT IN DEGREES
+C> @param RLON1 - REAL LONGITUDE OF THE FIRST GRID POINT IN DEGREES
+C> @param DLAT - REAL LATITUDE INCREMENT IN DEGREES SUCH THAT
+C> D(PHI)/D(J)=DLAT*COS(PHI) WHERE J IS MERIDIONAL INDEX.
+C> DLAT IS NEGATIVE FOR GRIDS INDEXED SOUTHWARD.
+C> (IN TERMS OF GRID INCREMENT DY VALID AT LATITUDE RLATI,
+C> THE LATITUDE INCREMENT DLAT IS DETERMINED AS
+C> DLAT=DPR*DY/(RERTH*COS(RLATI/DPR))
+C> WHERE DPR=180/PI AND RERTH IS EARTH'S RADIUS)
+C> @param DLON - REAL LONGITUDE INCREMENT IN DEGREES SUCH THAT
+C> D(LAMBDA)/D(I)=DLON WHERE I IS ZONAL INDEX.
+C> DLON IS NEGATIVE FOR GRIDS INDEXED WESTWARD.
+C> @param GRIDI - REAL (*) INPUT GRID FIELDS
+C> @param GM - REAL (*) MERCATOR FIELDS
+C>
+C> SUBPROGRAMS CALLED:
+C> - sptran() Perform a scalar spherical transform
+C> - sptgpm() Transform spectral scalar to Mercator
+C> - ncpus() Gets environment number of cpus
+C>
+C> MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL:
+C> DIMENSION |LINEAR |QUADRATIC
+C> ----------------------- |--------- |-------------
+C> IMAX | 2*MAXWV+2 | 3*MAXWV/2*2+2
+C> JMAX (IDRT=4,IROMB=0) | 1*MAXWV+1 | 3*MAXWV/2+1
+C> JMAX (IDRT=4,IROMB=1) | 2*MAXWV+1 | 5*MAXWV/2+1
+C> JMAX (IDRT=0,IROMB=0) | 2*MAXWV+3 | 3*MAXWV/2*2+3
+C> JMAX (IDRT=0,IROMB=1) | 4*MAXWV+3 | 5*MAXWV/2*2+3
+C> JMAX (IDRT=256,IROMB=0) | 2*MAXWV+1 | 3*MAXWV/2*2+1
+C> JMAX (IDRT=256,IROMB=1) | 4*MAXWV+1 | 5*MAXWV/2*2+1
+C>
+ SUBROUTINE SPTRUNM(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,MI,MJ,
+ & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP,
+ & NISKIP,NJSKIP,JCPU,RLAT1,RLON1,DLAT,DLON,
+ & GRIDI,GM)
+ REAL GRIDI(*),GM(*)
+ REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C TRANSFORM INPUT GRID TO WAVE
+ JC=JCPU
+ IF(JC.EQ.0) JC=NCPUS()
+ MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+ MDIM=2*MX+1
+ JN=-JSKIPI
+ IF(JN.EQ.0) JN=IMAXI
+ JS=-JN
+ INP=(JMAXI-1)*MAX(0,-JN)+1
+ ISP=(JMAXI-1)*MAX(0,-JS)+1
+ CALL SPTRAN(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,
+ & IPRIME,ISKIPI,JN,JS,MDIM,KSKIPI,0,0,JC,
+ & W,GRIDI(INP),GRIDI(ISP),-1)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C TRANSFORM WAVE TO OUTPUT
+ CALL SPTGPM(IROMB,MAXWV,KMAX,MI,MJ,MDIM,KGSKIP,NISKIP,NJSKIP,
+ & RLAT1,RLON1,DLAT,DLON,W,GM)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ END
diff --git a/src/sptrunmv.f b/src/sptrunmv.f
new file mode 100644
index 00000000..a9b5c92f
--- /dev/null
+++ b/src/sptrunmv.f
@@ -0,0 +1,153 @@
+C> @file
+C>
+C> Spectrally interpolate vectors to Mercator
+C> @author IREDELL @date 96-02-29
+
+C> THIS SUBPROGRAM SPECTRALLY TRUNCATES VECTOR FIELDS
+C> ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS
+C> TO A MERCATOR GRID.
+C> THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL.
+C> THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID
+C> (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID.
+C> THE GRID FIELDS MAY HAVE GENERAL INDEXING.
+C> THE TRANSFORMS ARE ALL MULTIPROCESSED.
+C> TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION.
+C> SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
+C>
+C> PROGRAM HISTORY LOG:
+C> 96-02-29 IREDELL
+C> 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED
+C>
+C> @param IROMB - INTEGER SPECTRAL DOMAIN SHAPE
+C> (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL)
+C> @param MAXWV - INTEGER SPECTRAL TRUNCATION
+C> @param IDRTI - INTEGER INPUT GRID IDENTIFIER
+C> (IDRTI=4 FOR GAUSSIAN GRID,
+C> IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES,
+C> IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES)
+C> @param IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES.
+C> @param JMAXI - INTEGER NUMBER OF INPUT LATITUDES.
+C> @param KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM.
+C> @param MI - INTEGER NUMBER OF POINTS IN THE FASTER ZONAL DIRECTION
+C> @param MJ - INTEGER NUMBER OF POINTS IN THE SLOWER MERID DIRECTION
+C> @param IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN.
+C> (DEFAULTS TO 1 IF IPRIME=0)
+C> (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.)
+C> @param ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES
+C> (DEFAULTS TO 1 IF ISKIPI=0)
+C> @param JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH
+C> (DEFAULTS TO -IMAXI IF JSKIPI=0)
+C> @param KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS
+C> (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0)
+C> @param KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS
+C> (DEFAULTS TO MI*MJ IF KGSKIP=0)
+C> @param NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS
+C> (DEFAULTS TO 1 IF NISKIP=0)
+C> @param NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS
+C> (DEFAULTS TO MI IF NJSKIP=0)
+C> @param JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS
+C> (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0)
+C> @param RLAT1 - REAL LATITUDE OF THE FIRST GRID POINT IN DEGREES
+C> @param RLON1 - REAL LONGITUDE OF THE FIRST GRID POINT IN DEGREES
+C> @param DLAT - REAL LATITUDE INCREMENT IN DEGREES SUCH THAT
+C> D(PHI)/D(J)=DLAT*COS(PHI) WHERE J IS MERIDIONAL INDEX.
+C> DLAT IS NEGATIVE FOR GRIDS INDEXED SOUTHWARD.
+C> (IN TERMS OF GRID INCREMENT DY VALID AT LATITUDE RLATI,
+C> THE LATITUDE INCREMENT DLAT IS DETERMINED AS
+C> DLAT=DPR*DY/(RERTH*COS(RLATI/DPR))
+C> WHERE DPR=180/PI AND RERTH IS EARTH'S RADIUS)
+C> @param DLON - REAL LONGITUDE INCREMENT IN DEGREES SUCH THAT
+C> D(LAMBDA)/D(I)=DLON WHERE I IS ZONAL INDEX.
+C> DLON IS NEGATIVE FOR GRIDS INDEXED WESTWARD.
+C> @param GRIDUI - REAL (*) INPUT GRID U-WINDS
+C> @param GRIDVI - REAL (*) INPUT GRID V-WINDS
+C> @param LUV - LOGICAL FLAG WHETHER TO RETURN WINDS
+C> @param LDZ - LOGICAL FLAG WHETHER TO RETURN DIVERGENCE AND VORTICITY
+C> @param LPS - LOGICAL FLAG WHETHER TO RETURN POTENTIAL AND STREAMFCN
+C> @param UM - REAL (*) MERCATOR U-WINDS IF LUV
+C> @param VM - REAL (*) MERCATOR V-WINDS IF LUV
+C> @param DM - REAL (*) MERCATOR DIVERGENCES IF LDZ
+C> @param ZM - REAL (*) MERCATOR VORTICITIES IF LDZ
+C> @param PM - REAL (*) MERCATOR POTENTIALS IF LPS
+C> @param SM - REAL (*) MERCATOR STREAMFCNS IF LPS
+C>
+C> SUBPROGRAMS CALLED:
+C> - SPWGET GET WAVE-SPACE CONSTANTS
+C> - SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE
+C> - SPTRANV PERFORM A VECTOR SPHERICAL TRANSFORM
+C> - SPTGPM TRANSFORM SPECTRAL SCALAR TO MERCATOR
+C> - SPTGPMV TRANSFORM SPECTRAL VECTOR TO MERCATOR
+C> - NCPUS GETS ENVIRONMENT NUMBER OF CPUS
+C>
+C> REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL:
+C> DIMENSION |LINEAR |QUADRATIC
+C> ----------------------- |--------- |-------------
+C> IMAX |2*MAXWV+2 |3*MAXWV/2*2+2
+C> JMAX (IDRT=4,IROMB=0) |1*MAXWV+1 |3*MAXWV/2+1
+C> JMAX (IDRT=4,IROMB=1) |2*MAXWV+1 |5*MAXWV/2+1
+C> JMAX (IDRT=0,IROMB=0) |2*MAXWV+3 |3*MAXWV/2*2+3
+C> JMAX (IDRT=0,IROMB=1) |4*MAXWV+3 |5*MAXWV/2*2+3
+C> JMAX (IDRT=256,IROMB=0) |2*MAXWV+1 |3*MAXWV/2*2+1
+C> JMAX (IDRT=256,IROMB=1) |4*MAXWV+1 |5*MAXWV/2*2+1
+ SUBROUTINE SPTRUNMV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,MI,MJ,
+ & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP,
+ & NISKIP,NJSKIP,JCPU,RLAT1,RLON1,DLAT,DLON,
+ & GRIDUI,GRIDVI,LUV,UM,VM,LDZ,DM,ZM,LPS,PM,SM)
+
+ LOGICAL LUV,LDZ,LPS
+ REAL GRIDUI(*),GRIDVI(*)
+ REAL UM(*),VM(*),DM(*),ZM(*),PM(*),SM(*)
+ REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX)
+ REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1)
+ REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1)
+ REAL WD((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX)
+ REAL WZ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C TRANSFORM INPUT GRID TO WAVE
+ JC=JCPU
+ IF(JC.EQ.0) JC=NCPUS()
+ MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+ MDIM=2*MX+1
+ JN=-JSKIPI
+ IF(JN.EQ.0) JN=IMAXI
+ JS=-JN
+ INP=(JMAXI-1)*MAX(0,-JN)+1
+ ISP=(JMAXI-1)*MAX(0,-JS)+1
+ CALL SPTRANV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,
+ & IPRIME,ISKIPI,JN,JS,MDIM,KSKIPI,0,0,JC,
+ & WD,WZ,
+ & GRIDUI(INP),GRIDUI(ISP),GRIDVI(INP),GRIDVI(ISP),-1)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C TRANSFORM WAVE TO OUTPUT WINDS
+ IF(LUV) THEN
+ CALL SPTGPMV(IROMB,MAXWV,KMAX,MI,MJ,MDIM,KGSKIP,NISKIP,NJSKIP,
+ & RLAT1,RLON1,DLAT,DLON,WD,WZ,UM,VM)
+ ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C TRANSFORM WAVE TO OUTPUT DIVERGENCE AND VORTICITY
+ IF(LDZ) THEN
+ CALL SPTGPM(IROMB,MAXWV,KMAX,MI,MJ,MDIM,KGSKIP,NISKIP,NJSKIP,
+ & RLAT1,RLON1,DLAT,DLON,WD,DM)
+ CALL SPTGPM(IROMB,MAXWV,KMAX,MI,MJ,MDIM,KGSKIP,NISKIP,NJSKIP,
+ & RLAT1,RLON1,DLAT,DLON,WZ,ZM)
+ ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C TRANSFORM WAVE TO OUTPUT POTENTIAL AND STREAMFUNCTION
+ IF(LPS) THEN
+ CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP)
+C$OMP PARALLEL DO
+ DO K=1,KMAX
+ CALL SPLAPLAC(IROMB,MAXWV,ENN1,WD(1,K),WD(1,K),-1)
+ CALL SPLAPLAC(IROMB,MAXWV,ENN1,WZ(1,K),WZ(1,K),-1)
+ WD(1:2,K)=0.
+ WZ(1:2,K)=0.
+ ENDDO
+ CALL SPTGPM(IROMB,MAXWV,KMAX,MI,MJ,MDIM,KGSKIP,NISKIP,NJSKIP,
+ & RLAT1,RLON1,DLAT,DLON,WD,PM)
+ CALL SPTGPM(IROMB,MAXWV,KMAX,MI,MJ,MDIM,KGSKIP,NISKIP,NJSKIP,
+ & RLAT1,RLON1,DLAT,DLON,WZ,SM)
+ ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ END
diff --git a/src/sptruns.f b/src/sptruns.f
new file mode 100644
index 00000000..a64a6866
--- /dev/null
+++ b/src/sptruns.f
@@ -0,0 +1,96 @@
+C> @file
+C>
+C> Spectrally interpolate scalars to polar stereo
+C> @author IREDELL @date 96-02-29
+
+C> This subprogram spectrally truncates scalar fields on a global
+C> cylindrical grid, returning the fields to specific pairs of polar
+C> stereographic scalar fields. The wave-space can be either
+C> triangular or rhomboidal. The grid-space can be either an
+C> equally-spaced grid (with or without pole points) or a Gaussian
+C> grid. The grid fields may have general indexing. The transforms
+C> are all multiprocessed. Transform several fields at a time to
+C> improve vectorization. Subprogram can be called from a
+C> multiprocessing environment.
+C>
+C> PROGRAM HISTORY LOG:
+C> 96-02-29 IREDELL
+C>
+C> @param IROMB - INTEGER SPECTRAL DOMAIN SHAPE
+C> (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL)
+C> @param MAXWV - INTEGER SPECTRAL TRUNCATION
+C> @param IDRTI - INTEGER INPUT GRID IDENTIFIER
+C> (IDRTI=4 FOR GAUSSIAN GRID,
+C> IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES,
+C> IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES)
+C> @param IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES.
+C> @param JMAXI - INTEGER NUMBER OF INPUT LATITUDES.
+C> @param KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM.
+C> @param NPS - INTEGER ODD ORDER OF THE POLAR STEREOGRAPHIC GRIDS
+C> @param IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN.
+C> (DEFAULTS TO 1 IF IPRIME=0)
+C> (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.)
+C> @param ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES
+C> (DEFAULTS TO 1 IF ISKIPI=0)
+C> @param JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH
+C> (DEFAULTS TO -IMAXI IF JSKIPI=0)
+C> @param KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS
+C> (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0)
+C> @param KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS
+C> (DEFAULTS TO NPS*NPS IF KGSKIP=0)
+C> @param NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS
+C> (DEFAULTS TO 1 IF NISKIP=0)
+C> @param NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS
+C> (DEFAULTS TO NPS IF NJSKIP=0)
+C> @param JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS
+C> (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0)
+C> @param TRUE - REAL LATITUDE AT WHICH PS GRID IS TRUE (USUALLY 60.)
+C> @param XMESH - REAL GRID LENGTH AT TRUE LATITUDE (M)
+C> @param ORIENT - REAL LONGITUDE AT BOTTOM OF NORTHERN PS GRID
+C> (SOUTHERN PS GRID WILL HAVE OPPOSITE ORIENTATION.)
+C> @param GRIDI - REAL (*) INPUT GRID FIELDS
+C> @param GN - REAL (*) NORTHERN POLAR STEREOGRAPHIC FIELDS
+C> @param GS - REAL (*) SOUTHERN POLAR STEREOGRAPHIC FIELDS
+C>
+C> SUBPROGRAMS CALLED:
+C> - sptran() Perform a scalar spherical transform
+C> - sptgps() Transform spectral scalar to polar stereo.
+C> - ncpus() Gets environment number of cpus
+C>
+C> Minimum grid dimensions for unaliased transforms to spectral:
+C> DIMENSION | LINEAR | QUADRATIC
+C> ----------------------- | --------- | -------------
+C> IMAX | 2*MAXWV+2 | 3*MAXWV/2*2+2
+C> JMAX (IDRT=4,IROMB=0) | 1*MAXWV+1 | 3*MAXWV/2+1
+C> JMAX (IDRT=4,IROMB=1) | 2*MAXWV+1 | 5*MAXWV/2+1
+C> JMAX (IDRT=0,IROMB=0) | 2*MAXWV+3 | 3*MAXWV/2*2+3
+C> JMAX (IDRT=0,IROMB=1) | 4*MAXWV+3 | 5*MAXWV/2*2+3
+C> JMAX (IDRT=256,IROMB=0) | 2*MAXWV+1 | 3*MAXWV/2*2+1
+C> JMAX (IDRT=256,IROMB=1) | 4*MAXWV+1 | 5*MAXWV/2*2+1
+C>
+ SUBROUTINE SPTRUNS(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,NPS,
+ & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP,
+ & NISKIP,NJSKIP,JCPU,TRUE,XMESH,ORIENT,
+ & GRIDI,GN,GS)
+ REAL GRIDI(*),GN(*),GS(*)
+ REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C TRANSFORM INPUT GRID TO WAVE
+ JC=JCPU
+ IF(JC.EQ.0) JC=NCPUS()
+ MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+ MDIM=2*MX+1
+ JN=-JSKIPI
+ IF(JN.EQ.0) JN=IMAXI
+ JS=-JN
+ INP=(JMAXI-1)*MAX(0,-JN)+1
+ ISP=(JMAXI-1)*MAX(0,-JS)+1
+ CALL SPTRAN(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,
+ & IPRIME,ISKIPI,JN,JS,MDIM,KSKIPI,0,0,JC,
+ & W,GRIDI(INP),GRIDI(ISP),-1)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C TRANSFORM WAVE TO OUTPUT
+ CALL SPTGPS(IROMB,MAXWV,KMAX,NPS,MDIM,KGSKIP,NISKIP,NJSKIP,
+ & TRUE,XMESH,ORIENT,W,GN,GS)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ END
diff --git a/src/sptrunsv.f b/src/sptrunsv.f
new file mode 100644
index 00000000..5d679e04
--- /dev/null
+++ b/src/sptrunsv.f
@@ -0,0 +1,149 @@
+C> @file
+C> @brief Spectrally interpolate vectors to polar stereo.
+C>
+C> 96-02-29 | Iredell | Initial.
+C> 1998-12-15 | Iredell | Openmp directives inserted.
+C>
+C> @author Iredell @date 96-02-29
+
+C> This subprogram spectrally truncates vector fields
+C> on a global cylindrical grid, returning the fields
+C> to specific pairs of polar stereographic scalar fields.
+C>
+C> The wave-space can be either triangular or rhomboidal.
+C>
+C> The grid-space can be either an equally-spaced grid
+C> (with or without pole points) or a gaussian grid.
+C>
+C> The grid fields may have general indexing.
+C>
+C> The transforms are all multiprocessed.
+C>
+C> Transform several fields at a time to improve vectorization.
+C>
+C> Subprogram can be called from a multiprocessing environment.
+C>
+C> Minimum grid dimensions for unaliased transforms to spectral:
+C> Dimension |Linear |Quadratic
+C> ----------------------- |--------- |-------------
+C> IMAX |2*MAXWV+2 |3*MAXWV/2*2+2
+C> JMAX (IDRT=4,IROMB=0) |1*MAXWV+1 |3*MAXWV/2+1
+C> JMAX (IDRT=4,IROMB=1) |2*MAXWV+1 |5*MAXWV/2+1
+C> JMAX (IDRT=0,IROMB=0) |2*MAXWV+3 |3*MAXWV/2*2+3
+C> JMAX (IDRT=0,IROMB=1) |4*MAXWV+3 |5*MAXWV/2*2+3
+C> JMAX (IDRT=256,IROMB=0) |2*MAXWV+1 |3*MAXWV/2*2+1
+C> JMAX (IDRT=256,IROMB=1) |4*MAXWV+1 |5*MAXWV/2*2+1
+C>
+C> @param IROMB integer spectral domain shape
+C> (0 for triangular, 1 for rhomboidal)
+C> @param MAXWV integer spectral truncation
+C> @param IDRTI integer input grid identifier
+C> - IDRTI=4 for Gaussian grid
+C> - IDRTI=0 for equally-spaced grid including poles
+C> - IDRTI=256 for equally-spaced grid excluding poles
+C> @param IMAXI integer even number of input longitudes.
+C> @param JMAXI integer number of input latitudes.
+C> @param KMAX integer number of fields to transform.
+C> @param NPS integer odd order of the polar stereographic grids
+C> @param IPRIME integer input longitude index for the prime meridian.
+C> (defaults to 1 if IPRIME=0)
+C> (output longitude index for prime meridian assumed 1.)
+C> @param ISKIPI integer skip number between input longitudes
+C> (defaults to 1 if ISKIPI=0)
+C> @param JSKIPI integer skip number between input latitudes from south
+C> (defaults to -IMAXI if JSKIPI=0)
+C> @param KSKIPI integer skip number between input grid fields
+C> (defaults to IMAXI*JMAXI if KSKIPI=0)
+C> @param KGSKIP integer skip number between grid fields
+C> (defaults to NPS*NPS if KGSKIP=0)
+C> @param NISKIP integer skip number between grid i-points
+C> (defaults to 1 if NISKIP=0)
+C> @param NJSKIP integer skip number between grid j-points
+C> (defaults to NPS if NJSKIP=0)
+C> @param JCPU integer number of cpus over which to multiprocess
+C> (defaults to environment NCPUS if JCPU=0)
+C> @param TRUE real latitude at which ps grid is true (usually 60.)
+C> @param XMESH real grid length at true latitude (m)
+C> @param ORIENT real longitude at bottom of Northern PS grid
+C> (Southern PS grid will have opposite orientation.)
+C> @param GRIDUI real input grid u-winds
+C> @param GRIDVI real input grid v-winds
+C> @param LUV logical flag whether to return winds
+C> @param LDZ logical flag whether to return divergence and vorticity
+C> @param LPS logical flag whether to return potential and streamfcn
+C> @param UN real northern ps u-winds if luv
+C> @param VN real northern ps v-winds if luv
+C> @param US real southern ps u-winds if luv
+C> @param VS real southern ps v-winds if luv
+C> @param DN real northern divergences if ldz
+C> @param ZN real northern vorticities if ldz
+C> @param DS real southern divergences if ldz
+C> @param ZS real southern vorticities if ldz
+C> @param PN real northern potentials if lps
+C> @param SN real northern streamfcns if lps
+C> @param PS real southern potentials if lps
+C> @param SS real southern streamfcns if lps
+C>
+C> @author Iredell @date 96-02-29
+ SUBROUTINE SPTRUNSV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,NPS,
+ & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP,
+ & NISKIP,NJSKIP,JCPU,TRUE,XMESH,ORIENT,
+ & GRIDUI,GRIDVI,
+ & LUV,UN,VN,US,VS,LDZ,DN,ZN,DS,ZS,
+ & LPS,PN,SN,PS,SS)
+ LOGICAL LUV,LDZ,LPS
+ REAL GRIDUI(*),GRIDVI(*)
+ REAL UN(*),VN(*),US(*),VS(*),DN(*),ZN(*),DS(*),ZS(*)
+ REAL PN(*),SN(*),PS(*),SS(*)
+ REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1)
+ REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1)
+ REAL WD((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX)
+ REAL WZ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX)
+
+C TRANSFORM INPUT GRID TO WAVE
+ JC=JCPU
+ IF(JC.EQ.0) JC=NCPUS()
+ MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+ MDIM=2*MX+1
+ JN=-JSKIPI
+ IF(JN.EQ.0) JN=IMAXI
+ JS=-JN
+ INP=(JMAXI-1)*MAX(0,-JN)+1
+ ISP=(JMAXI-1)*MAX(0,-JS)+1
+ CALL SPTRANV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,
+ & IPRIME,ISKIPI,JN,JS,MDIM,KSKIPI,0,0,JC,
+ & WD,WZ,
+ & GRIDUI(INP),GRIDUI(ISP),GRIDVI(INP),GRIDVI(ISP),-1)
+
+C TRANSFORM WAVE TO OUTPUT WINDS
+ IF(LUV) THEN
+ CALL SPTGPSV(IROMB,MAXWV,KMAX,NPS,MDIM,KGSKIP,NISKIP,NJSKIP,
+ & TRUE,XMESH,ORIENT,WD,WZ,UN,VN,US,VS)
+ ENDIF
+
+C TRANSFORM WAVE TO OUTPUT DIVERGENCE AND VORTICITY
+ IF(LDZ) THEN
+ CALL SPTGPS(IROMB,MAXWV,KMAX,NPS,MDIM,KGSKIP,NISKIP,NJSKIP,
+ & TRUE,XMESH,ORIENT,WD,DN,DS)
+ CALL SPTGPS(IROMB,MAXWV,KMAX,NPS,MDIM,KGSKIP,NISKIP,NJSKIP,
+ & TRUE,XMESH,ORIENT,WZ,ZN,ZS)
+ ENDIF
+
+C TRANSFORM WAVE TO OUTPUT POTENTIAL AND STREAMFUNCTION
+ IF(LPS) THEN
+ CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP)
+C$OMP PARALLEL DO
+ DO K=1,KMAX
+ CALL SPLAPLAC(IROMB,MAXWV,ENN1,WD(1,K),WD(1,K),-1)
+ CALL SPLAPLAC(IROMB,MAXWV,ENN1,WZ(1,K),WZ(1,K),-1)
+ WD(1:2,K)=0.
+ WZ(1:2,K)=0.
+ ENDDO
+ CALL SPTGPS(IROMB,MAXWV,KMAX,NPS,MDIM,KGSKIP,NISKIP,NJSKIP,
+ & TRUE,XMESH,ORIENT,WD,PN,PS)
+ CALL SPTGPS(IROMB,MAXWV,KMAX,NPS,MDIM,KGSKIP,NISKIP,NJSKIP,
+ & TRUE,XMESH,ORIENT,WZ,SN,SS)
+ ENDIF
+ END
diff --git a/src/sptrunv.f b/src/sptrunv.f
new file mode 100644
index 00000000..83e30a99
--- /dev/null
+++ b/src/sptrunv.f
@@ -0,0 +1,162 @@
+C> @file
+C>
+C> Spectrally truncate gridded vector fields
+C> @author IREDELL @date 96-02-29
+
+C> This subprogram spectrally truncates vector fields
+C> on a global cylindrical grid, returning the fields
+C> to a possibly different global cylindrical grid.
+C> The wave-space can be either triangular or rhomboidal.
+C> Either grid-space can be either an equally-spaced grid
+C> (with or without pole points) or a Gaussian grid.
+C> The grid fields may have general indexing.
+C> The transforms are all multiprocessed.
+C> Over zonal wavenumber to ensure reproducibility.
+C> Transform several fields at a time to improve vectorization.
+C> Subprogram can be called from a multiprocessing environment.
+C>
+C> PROGRAM HISTORY LOG:
+C> - 96-02-29 IREDELL
+C> - 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED
+C>
+C> @param IROMB - INTEGER SPECTRAL DOMAIN SHAPE
+C> (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL)
+C> @param MAXWV - INTEGER SPECTRAL TRUNCATION
+C> @param IDRTI - INTEGER INPUT GRID IDENTIFIER
+C> (IDRTI=4 FOR GAUSSIAN GRID,
+C> IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES,
+C> IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES)
+C> @param IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES.
+C> @param JMAXI - INTEGER NUMBER OF INPUT LATITUDES.
+C> @param IDRTO - INTEGER OUTPUT GRID IDENTIFIER
+C> (IDRTO=4 FOR GAUSSIAN GRID,
+C> IDRTO=0 FOR EQUALLY-SPACED GRID INCLUDING POLES,
+C> IDRTO=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES)
+C> @param IMAXO - INTEGER EVEN NUMBER OF OUTPUT LONGITUDES.
+C> @param JMAXO - INTEGER NUMBER OF OUTPUT LATITUDES.
+C> @param KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM.
+C> @param IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN.
+C> (DEFAULTS TO 1 IF IPRIME=0)
+C> (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.)
+C> @param ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES
+C> (DEFAULTS TO 1 IF ISKIPI=0)
+C> @param JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH
+C> (DEFAULTS TO -IMAXI IF JSKIPI=0)
+C> @param KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS
+C> (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0)
+C> @param ISKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT LONGITUDES
+C> (DEFAULTS TO 1 IF ISKIPO=0)
+C> @param JSKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT LATITUDES FROM SOUTH
+C> (DEFAULTS TO -IMAXO IF JSKIPO=0)
+C> @param KSKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT GRID FIELDS
+C> (DEFAULTS TO IMAXO*JMAXO IF KSKIPO=0)
+C> @param JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS
+C> (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0)
+C> @param GRIDUI - REAL (*) INPUT GRID U-WINDS
+C> @param GRIDVI - REAL (*) INPUT GRID V-WINDS
+C> @param LUV - LOGICAL FLAG WHETHER TO RETURN WINDS
+C> @param LDZ - LOGICAL FLAG WHETHER TO RETURN DIVERGENCE AND VORTICITY
+C> @param LPS - LOGICAL FLAG WHETHER TO RETURN POTENTIAL AND STREAMFCN
+C> @param GRIDUO - REAL (*) OUTPUT U-WINDS IF LUV
+C> (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE)
+C> @param GRIDVO - REAL (*) OUTPUT V-WINDS IF LUV
+C> (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE)
+C> @param GRIDDO - REAL (*) OUTPUT DIVERGENCES IF LDZ
+C> (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE)
+C> @param GRIDZO - REAL (*) OUTPUT VORTICITIES IF LDZ
+C> (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE)
+C> @param GRIDPO - REAL (*) OUTPUT POTENTIALS IF LPS
+C> (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE)
+C> @param GRIDSO - REAL (*) OUTPUT STREAMFCNS IF LPS
+C> (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE)
+C>
+C> SUBPROGRAMS CALLED:
+C> - SPWGET() GET WAVE-SPACE CONSTANTS
+C> - SPLAPLAC() COMPUTE LAPLACIAN IN SPECTRAL SPACE
+C> - SPTRAN() PERFORM A SCALAR SPHERICAL TRANSFORM
+C> - SPTRANV() PERFORM A VECTOR SPHERICAL TRANSFORM
+C> - NCPUS() GETS ENVIRONMENT NUMBER OF CPUS
+C>
+C> REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL:
+C> DIMENSION |LINEAR |QUADRATIC
+C> ----------------------- |--------- |-------------
+C> IMAX |2*MAXWV+2 |3*MAXWV/2*2+2
+C> JMAX (IDRT=4,IROMB=0) |1*MAXWV+1 |3*MAXWV/2+1
+C> JMAX (IDRT=4,IROMB=1) |2*MAXWV+1 |5*MAXWV/2+1
+C> JMAX (IDRT=0,IROMB=0) |2*MAXWV+3 |3*MAXWV/2*2+3
+C> JMAX (IDRT=0,IROMB=1) |4*MAXWV+3 |5*MAXWV/2*2+3
+C> JMAX (IDRT=256,IROMB=0) |2*MAXWV+1 |3*MAXWV/2*2+1
+C> JMAX (IDRT=256,IROMB=1) |4*MAXWV+1 |5*MAXWV/2*2+1
+ SUBROUTINE SPTRUNV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,
+ & IDRTO,IMAXO,JMAXO,KMAX,
+ & IPRIME,ISKIPI,JSKIPI,KSKIPI,
+ & ISKIPO,JSKIPO,KSKIPO,JCPU,GRIDUI,GRIDVI,
+ & LUV,GRIDUO,GRIDVO,LDZ,GRIDDO,GRIDZO,
+ & LPS,GRIDPO,GRIDSO)
+ LOGICAL LUV,LDZ,LPS
+ REAL GRIDUI(*),GRIDVI(*)
+ REAL GRIDUO(*),GRIDVO(*),GRIDDO(*),GRIDZO(*),GRIDPO(*),GRIDSO(*)
+ REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1)
+ REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1)
+ REAL WD((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX)
+ REAL WZ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C TRANSFORM INPUT GRID TO WAVE
+ JC=JCPU
+ IF(JC.EQ.0) JC=NCPUS()
+ MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+ MDIM=2*MX+1
+ JN=-JSKIPI
+ IF(JN.EQ.0) JN=IMAXI
+ JS=-JN
+ INP=(JMAXI-1)*MAX(0,-JN)+1
+ ISP=(JMAXI-1)*MAX(0,-JS)+1
+ CALL SPTRANV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,
+ & IPRIME,ISKIPI,JN,JS,MDIM,KSKIPI,0,0,JC,
+ & WD,WZ,
+ & GRIDUI(INP),GRIDUI(ISP),GRIDVI(INP),GRIDVI(ISP),-1)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C TRANSFORM WAVE TO OUTPUT WINDS
+ JN=-JSKIPO
+ IF(JN.EQ.0) JN=IMAXO
+ JS=-JN
+ INP=(JMAXO-1)*MAX(0,-JN)+1
+ ISP=(JMAXO-1)*MAX(0,-JS)+1
+ IF(LUV) THEN
+ CALL SPTRANV(IROMB,MAXWV,IDRTO,IMAXO,JMAXO,KMAX,
+ & 0,ISKIPO,JN,JS,MDIM,KSKIPO,0,0,JC,
+ & WD,WZ,
+ & GRIDUO(INP),GRIDUO(ISP),GRIDVO(INP),GRIDVO(ISP),1)
+ ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C TRANSFORM WAVE TO OUTPUT DIVERGENCE AND VORTICITY
+ IF(LDZ) THEN
+ CALL SPTRAN(IROMB,MAXWV,IDRTO,IMAXO,JMAXO,KMAX,
+ & 0,ISKIPO,JN,JS,MDIM,KSKIPO,0,0,JC,
+ & WD,GRIDDO(INP),GRIDDO(ISP),1)
+ CALL SPTRAN(IROMB,MAXWV,IDRTO,IMAXO,JMAXO,KMAX,
+ & 0,ISKIPO,JN,JS,MDIM,KSKIPO,0,0,JC,
+ & WZ,GRIDZO(INP),GRIDZO(ISP),1)
+ ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C TRANSFORM WAVE TO OUTPUT POTENTIAL AND STREAMFUNCTION
+ IF(LPS) THEN
+ CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP)
+C$OMP PARALLEL DO
+ DO K=1,KMAX
+ CALL SPLAPLAC(IROMB,MAXWV,ENN1,WD(1,K),WD(1,K),-1)
+ CALL SPLAPLAC(IROMB,MAXWV,ENN1,WZ(1,K),WZ(1,K),-1)
+ WD(1:2,K)=0.
+ WZ(1:2,K)=0.
+ ENDDO
+ CALL SPTRAN(IROMB,MAXWV,IDRTO,IMAXO,JMAXO,KMAX,
+ & 0,ISKIPO,JN,JS,MDIM,KSKIPO,0,0,JC,
+ & WD,GRIDPO(INP),GRIDPO(ISP),1)
+ CALL SPTRAN(IROMB,MAXWV,IDRTO,IMAXO,JMAXO,KMAX,
+ & 0,ISKIPO,JN,JS,MDIM,KSKIPO,0,0,JC,
+ & WZ,GRIDSO(INP),GRIDSO(ISP),1)
+ ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ END
diff --git a/src/spuv2dz.f b/src/spuv2dz.f
new file mode 100644
index 00000000..a27b4628
--- /dev/null
+++ b/src/spuv2dz.f
@@ -0,0 +1,91 @@
+C> @file
+C> @brief Compute divergence and vorticity from winds.
+C> @author Iredell @date 92-10-31
+
+C> Computes the divergence and vorticity from wind components
+C> in spectral space.
+C>
+C> Subprogram speps() should be called already.
+C>
+C> If L is the zonal wavenumber, N is the total wavenumber,
+C> EPS(L,N)=SQRT((N**2-L**2)/(4*N**2-1)) and A is earth radius,
+C> then the divergence D is computed as:
+C>
+C> D(L,N)=I*L*A*U(L,N)
+C> +EPS(L,N+1)*N*A*V(L,N+1)-EPS(L,N)*(N+1)*A*V(L,N-1)
+C>
+C>
+C> and the vorticity Z is computed as:
+C>
+C> Z(L,N)=I*L*A*V(L,N)
+C> -EPS(L,N+1)*N*A*U(L,N+1)+EPS(L,N)*(N+1)*A*U(L,N-1)
+C>
+C>
+C> where U is the zonal wind and V is the meridional wind.
+C>
+C> U and V are weighted by the secant of latitude.
+C>
+C> Extra terms are used over top of the spectral domain.
+C>
+C> Advantage is taken of the fact that EPS(L,L)=0
+C> in order to vectorize over the entire spectral domain.
+C>
+C> @param I integer spectral domain shape
+C> (0 for triangular, 1 for rhomboidal)
+C> @param M INTEGER spectral truncation
+C> @param ENN1 ((M+1)*((I+1)*M+2)/2) N*(N+1)/A**2
+C> @param ELONN1 ((M+1)*((I+1)*M+2)/2) L/(N*(N+1))*A
+C> @param EON ((M+1)*((I+1)*M+2)/2) EPSILON/N*A
+C> @param EONTOP (M+1) EPSILON/N*A over top
+C> @param U ((M+1)*((I+1)*M+2)) zonal wind (over coslat)
+C> @param V ((M+1)*((I+1)*M+2)) merid wind (over coslat)
+C> @param UTOP (2*(M+1)) zonal wind (over coslat) over top
+C> @param VTOP (2*(M+1)) merid wind (over coslat) over top
+C> @param D ((M+1)*((I+1)*M+2)) divergence
+C> @param Z ((M+1)*((I+1)*M+2)) vorticity
+C>
+C> @author Iredell @date 92-10-31
+ SUBROUTINE SPUV2DZ(I,M,ENN1,ELONN1,EON,EONTOP,U,V,UTOP,VTOP,D,Z)
+ REAL ENN1((M+1)*((I+1)*M+2)/2),ELONN1((M+1)*((I+1)*M+2)/2)
+ REAL EON((M+1)*((I+1)*M+2)/2),EONTOP(M+1)
+ REAL U((M+1)*((I+1)*M+2)),V((M+1)*((I+1)*M+2))
+ REAL UTOP(2*(M+1)),VTOP(2*(M+1))
+ REAL D((M+1)*((I+1)*M+2)),Z((M+1)*((I+1)*M+2))
+
+C COMPUTE TERMS FROM THE SPECTRAL DOMAIN
+ K=1
+ D(2*K-1)=0.
+ D(2*K)=0.
+ Z(2*K-1)=0.
+ Z(2*K)=0.
+ DO K=2,(M+1)*((I+1)*M+2)/2-1
+ D(2*K-1)=-ELONN1(K)*U(2*K)+EON(K+1)*V(2*K+1)-EON(K)*V(2*K-3)
+ D(2*K)=ELONN1(K)*U(2*K-1)+EON(K+1)*V(2*K+2)-EON(K)*V(2*K-2)
+ Z(2*K-1)=-ELONN1(K)*V(2*K)-EON(K+1)*U(2*K+1)+EON(K)*U(2*K-3)
+ Z(2*K)=ELONN1(K)*V(2*K-1)-EON(K+1)*U(2*K+2)+EON(K)*U(2*K-2)
+ ENDDO
+ K=(M+1)*((I+1)*M+2)/2
+ D(2*K-1)=-ELONN1(K)*U(2*K)-EON(K)*V(2*K-3)
+ D(2*K)=ELONN1(K)*U(2*K-1)-EON(K)*V(2*K-2)
+ Z(2*K-1)=-ELONN1(K)*V(2*K)+EON(K)*U(2*K-3)
+ Z(2*K)=ELONN1(K)*V(2*K-1)+EON(K)*U(2*K-2)
+
+C COMPUTE TERMS FROM OVER TOP OF THE SPECTRAL DOMAIN
+CDIR$ IVDEP
+ DO L=0,M
+ K=L*(2*M+(I-1)*(L-1))/2+I*L+M+1
+ D(2*K-1)=D(2*K-1)+EONTOP(L+1)*VTOP(2*L+1)
+ D(2*K)=D(2*K)+EONTOP(L+1)*VTOP(2*L+2)
+ Z(2*K-1)=Z(2*K-1)-EONTOP(L+1)*UTOP(2*L+1)
+ Z(2*K)=Z(2*K)-EONTOP(L+1)*UTOP(2*L+2)
+ ENDDO
+
+C MULTIPLY BY LAPLACIAN TERM
+ DO K=2,(M+1)*((I+1)*M+2)/2
+ D(2*K-1)=D(2*K-1)*ENN1(K)
+ D(2*K)=D(2*K)*ENN1(K)
+ Z(2*K-1)=Z(2*K-1)*ENN1(K)
+ Z(2*K)=Z(2*K)*ENN1(K)
+ ENDDO
+ RETURN
+ END
diff --git a/src/spvar.f b/src/spvar.f
new file mode 100644
index 00000000..4b6fa00b
--- /dev/null
+++ b/src/spvar.f
@@ -0,0 +1,35 @@
+C> @file
+C> @brief Compute variance by total wavenumber.
+C> @author Iredell @date 92-10-31
+
+C> Computes the variances by total wavenumber
+C> of a scalar field in spectral space.
+C>
+C> @param I spectral domain shape
+C> (0 for triangular, 1 for rhomboidal)
+C> @param M spectral truncation
+C> @param Q ((M+1)*((I+1)*M+2)) scalar field
+C> @param QVAR (0:(I+1)*M) variances
+C>
+C> @author Iredell @date 92-10-31
+ SUBROUTINE SPVAR(I,M,Q,QVAR)
+ REAL Q((M+1)*((I+1)*M+2))
+ REAL QVAR(0:(I+1)*M)
+
+ L=0
+ DO N=0,M
+ KS=L*(2*M+(I-1)*(L-1))+2*N
+ QVAR(N)=0.5*Q(KS+1)**2
+ ENDDO
+ DO N=M+1,(I+1)*M
+ QVAR(N)=0.
+ ENDDO
+ DO N=0,(I+1)*M
+ DO L=MAX(1,N-M),MIN(N,M)
+ KS=L*(2*M+(I-1)*(L-1))+2*N
+ QVAR(N)=QVAR(N)+Q(KS+1)**2+Q(KS+2)**2
+ ENDDO
+ ENDDO
+
+ RETURN
+ END
diff --git a/src/spwget.f b/src/spwget.f
new file mode 100644
index 00000000..4eb15383
--- /dev/null
+++ b/src/spwget.f
@@ -0,0 +1,26 @@
+C> @file
+C> @brief Get wave-space constants.
+C> @author Iredell @date 96-02-29
+
+C> This subprogram gets wave-space constants.
+C>
+C> @param IROMB spectral domain shape (0 for triangular, 1 for rhomboidal)
+C> @param MAXWV spectral truncation
+C> @param EPS
+C> @param EPSTOP
+C> @param ENN1
+C> @param ELONN1
+C> @param EON
+C> @param EONTOP
+C>
+C> @author Iredell @date 96-02-29
+ SUBROUTINE SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP)
+ REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1)
+ REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
+ REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1)
+
+ MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
+ MXTOP=MAXWV+1
+ CALL SPEPS(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP)
+ END
diff --git a/tests/CMakeLists.txt b/tests/CMakeLists.txt
index 6bd06865..865e18bd 100644
--- a/tests/CMakeLists.txt
+++ b/tests/CMakeLists.txt
@@ -1,6 +1,26 @@
# This is the CMake file for the test directory of NCEPLIBS-ip.
#
-# Mark Potts, Kyle Gerheiser, Eric Engle
+# Alex Richert, Mark Potts, Kyle Gerheiser, Eric Engle
+
+function(create_sp_test name kind timeout)
+ add_executable(${name}_${kind} ${name}.F90)
+
+ # Include openMP if desired.
+ if(OpenMP_Fortran_FOUND)
+ target_link_libraries(${name}_${kind} PRIVATE OpenMP::OpenMP_Fortran)
+ endif()
+ target_link_libraries(${name}_${kind} PRIVATE ip::ip_${kind})
+ if(CMAKE_Fortran_COMPILER_ID MATCHES "^(Intel|IntelLLVM)$")
+ set_target_properties(${name}_${kind} PROPERTIES COMPILE_FLAGS "-convert big_endian ${fortran_${kind}_flags}")
+ elseif(${CMAKE_Fortran_COMPILER_ID} MATCHES "^(GNU)$")
+ set_target_properties(${name}_${kind} PROPERTIES COMPILE_FLAGS "-fconvert=big-endian ${fortran_${kind}_flags}")
+ endif()
+ add_test(NAME ${name}_${kind} COMMAND ${name}_${kind})
+ target_compile_definitions(${name}_${kind} PRIVATE KIND_${kind})
+ if(TEST_TIME_LIMIT)
+ set_tests_properties(${name}_${kind} PROPERTIES TIMEOUT ${timeout})
+ endif()
+endfunction()
# Link data directory to find the test data.
execute_process(COMMAND cmake -E create_symlink
@@ -21,45 +41,41 @@ if(${CMAKE_Fortran_COMPILER_ID} MATCHES "^(GNU)$" AND ${CMAKE_Fortran_COMPILER_V
endif()
foreach(kind ${kinds})
- set(BUILD_FLAGS "${fortran_${kind}_flags}")
string(TOUPPER ${kind} kind_definition)
# Test ipxwafs routines
add_executable(test_ipxwafs_${kind} test_ipxwafs.F90)
target_link_libraries(test_ipxwafs_${kind} PUBLIC ip::ip_${kind})
- target_link_libraries(test_ipxwafs_${kind} PUBLIC sp::sp_${kind})
target_compile_definitions(test_ipxwafs_${kind} PRIVATE "LSIZE=${kind_definition}")
- set_target_properties(test_ipxwafs_${kind} PROPERTIES COMPILE_FLAGS "${BUILD_FLAGS}")
+ set_target_properties(test_ipxwafs_${kind} PROPERTIES COMPILE_FLAGS "${fortran_${kind}_flags}")
add_test(test_ipxwafs_${kind} test_ipxwafs_${kind})
# Test earth_radius_mod.
add_executable(test_earth_radius_${kind} test_earth_radius.F90)
target_link_libraries(test_earth_radius_${kind} PUBLIC ip::ip_${kind})
- target_link_libraries(test_earth_radius_${kind} PUBLIC sp::sp_${kind})
target_compile_definitions(test_earth_radius_${kind} PRIVATE "LSIZE=${kind_definition}")
- set_target_properties(test_earth_radius_${kind} PROPERTIES COMPILE_FLAGS "${BUILD_FLAGS}")
+ set_target_properties(test_earth_radius_${kind} PROPERTIES COMPILE_FLAGS "${fortran_${kind}_flags}")
add_test(test_earth_radius_${kind} test_earth_radius_${kind})
# grib-2 tests
- add_library(test_library_grib2_${kind} input_data_mod_grib2.F90 interp_mod_grib2.F90)
+ add_library(test_library_grib2_${kind} input_data_mod_grib2_${kind}.F90 interp_mod_grib2_${kind}.F90)
target_link_libraries(test_library_grib2_${kind} PUBLIC ip::ip_${kind})
- target_link_libraries(test_library_grib2_${kind} PUBLIC sp::sp_${kind})
target_compile_definitions(test_library_grib2_${kind} PRIVATE "LSIZE=${kind_definition}")
- set_target_properties(test_library_grib2_${kind} PROPERTIES COMPILE_FLAGS "${BUILD_FLAGS}")
+ set_target_properties(test_library_grib2_${kind} PROPERTIES COMPILE_FLAGS "${fortran_${kind}_flags}")
add_executable(tst_gdswzd_grib2_${kind} tst_gdswzd_grib2.c)
set_target_properties(tst_gdswzd_grib2_${kind} PROPERTIES LINKER_LANGUAGE C)
target_compile_definitions(tst_gdswzd_grib2_${kind} PRIVATE "LSIZE=${kind_definition}")
+ target_link_libraries(tst_gdswzd_grib2_${kind} PRIVATE test_library_grib2_${kind})
+
add_executable(test_scalar_grib2_${kind} test_scalar_grib2.F90)
add_executable(test_vector_grib2_${kind} test_vector_grib2.F90)
-
- target_link_libraries(tst_gdswzd_grib2_${kind} PRIVATE test_library_grib2_${kind})
target_link_libraries(test_scalar_grib2_${kind} PRIVATE test_library_grib2_${kind})
target_link_libraries(test_vector_grib2_${kind} PRIVATE test_library_grib2_${kind})
target_compile_definitions(test_scalar_grib2_${kind} PRIVATE "LSIZE=${kind_definition}")
target_compile_definitions(test_vector_grib2_${kind} PRIVATE "LSIZE=${kind_definition}")
- set_target_properties(test_scalar_grib2_${kind} PROPERTIES COMPILE_FLAGS "${BUILD_FLAGS}")
- set_target_properties(test_vector_grib2_${kind} PROPERTIES COMPILE_FLAGS "${BUILD_FLAGS}")
+ set_target_properties(test_scalar_grib2_${kind} PROPERTIES COMPILE_FLAGS "${fortran_${kind}_flags}")
+ set_target_properties(test_vector_grib2_${kind} PROPERTIES COMPILE_FLAGS "${fortran_${kind}_flags}")
add_test(tst_gdswzd_c_grib2_${kind} tst_gdswzd_grib2_${kind})
@@ -98,24 +114,24 @@ foreach(kind ${kinds})
add_test(test_station_points_neighbor_budget_vector_grib2_${kind} test_vector_grib2_${kind} -1 6)
# grib-1 tests
- add_library(test_library_grib1_${kind} input_data_mod_grib1.F90 interp_mod_grib1.F90)
+ add_library(test_library_grib1_${kind} input_data_mod_grib1_${kind}.F90 interp_mod_grib1_${kind}.F90)
target_link_libraries(test_library_grib1_${kind} PUBLIC ip::ip_${kind})
- target_link_libraries(test_library_grib1_${kind} PUBLIC sp::sp_${kind})
target_compile_definitions(test_library_grib1_${kind} PRIVATE "LSIZE=${kind_definition}")
- set_target_properties(test_library_grib1_${kind} PROPERTIES COMPILE_FLAGS "${BUILD_FLAGS}")
+ set_target_properties(test_library_grib1_${kind} PROPERTIES COMPILE_FLAGS "${fortran_${kind}_flags}")
add_executable(tst_gdswzd_grib1_${kind} tst_gdswzd_grib1.c)
set_target_properties(tst_gdswzd_grib1_${kind} PROPERTIES LINKER_LANGUAGE C)
target_compile_definitions(tst_gdswzd_grib1_${kind} PRIVATE "LSIZE=${kind_definition}")
+ target_link_libraries(tst_gdswzd_grib1_${kind} ip::ip_${kind})
+
add_executable(test_scalar_grib1_${kind} test_scalar_grib1.F90)
add_executable(test_vector_grib1_${kind} test_vector_grib1.F90)
- set_target_properties(test_scalar_grib1_${kind} PROPERTIES COMPILE_FLAGS "${BUILD_FLAGS}")
- set_target_properties(test_vector_grib1_${kind} PROPERTIES COMPILE_FLAGS "${BUILD_FLAGS}")
-
target_link_libraries(test_scalar_grib1_${kind} PRIVATE test_library_grib1_${kind})
target_link_libraries(test_vector_grib1_${kind} PRIVATE test_library_grib1_${kind})
- target_link_libraries(tst_gdswzd_grib1_${kind} ip::ip_${kind})
- target_link_libraries(tst_gdswzd_grib1_${kind} sp::sp_${kind})
+ target_compile_definitions(test_scalar_grib1_${kind} PRIVATE "LSIZE=${kind_definition}")
+ target_compile_definitions(test_vector_grib1_${kind} PRIVATE "LSIZE=${kind_definition}")
+ set_target_properties(test_scalar_grib1_${kind} PROPERTIES COMPILE_FLAGS "${fortran_${kind}_flags}")
+ set_target_properties(test_vector_grib1_${kind} PROPERTIES COMPILE_FLAGS "${fortran_${kind}_flags}")
add_test(tst_gdswzd_c_grib1_${kind} tst_gdswzd_grib1_${kind})
add_test(test_lambert_bilinear_scalar_grib1_${kind} test_scalar_grib1_${kind} 218 0)
@@ -134,5 +150,14 @@ foreach(kind ${kinds})
add_test(test_polar_stereo_neighbor_budget_vector_grib1_${kind} test_vector_grib1_${kind} 212 6)
add_test(test_rotatedB_spectral_vector_grib1_${kind} test_vector_grib1_${kind} 205 4)
add_test(test_rotatedE_budget_vector_grib1_${kind} test_vector_grib1_${kind} 203 3)
-endforeach()
+ # sp tests
+ create_sp_test(test_ncpus ${kind} 0.3)
+ create_sp_test(test_splaplac ${kind} 0.3)
+ create_sp_test(test_splat ${kind} 0.3)
+ create_sp_test(test_sppad ${kind} 0.3)
+ create_sp_test(test_sptezv ${kind} 0.3)
+ create_sp_test(test_fft ${kind} 0.3)
+ create_sp_test(test_sptrung ${kind} 0.3)
+ create_sp_test(test_sptrungv ${kind} 2)
+endforeach()
diff --git a/tests/data/README b/tests/data/README
new file mode 100644
index 00000000..d5c7cc38
--- /dev/null
+++ b/tests/data/README
@@ -0,0 +1,5 @@
+sptrungv* files were generated from ip's './test_vector_grib1_4 "205" "4"' test case and modifying spectral_interp_mod.F90 to write out UI, VI, RLAT, and RLON immediately before the SPTRUNGV call, and UO and VO immediately after.
+
+sptrung* files were generated from ip's 'test_scalar_grib2_4 "-1" "4"' test case and modifying spectral_interp_mod.F90 to write out GI.
+
+The other input and reference data can largely be rebuilt using the commented blocks in interp_mod_grib1.F90 and interp_mod_grib2.F90.
diff --git a/tests/data/sptrung.gi.in b/tests/data/sptrung.gi.in
new file mode 100644
index 0000000000000000000000000000000000000000..4085532bf6fa6939386209b8cd5c4014f03746f0
GIT binary patch
literal 259208
zcmeI5FHEi5vgJu00)apv5C{YUfj}S-2wn$)Kp>VtAP@)y0q(eHSLtaQ{
zr?X|tE1$gb$|J9A`Q#HVTK4#@J;y$^=l;I+e*p_>CgW7inpHLD9J9XK>+E~)d%ger
zFH1{H|Mp)J$wAgY)sqd%fR#&Ek7|%N$uNZ&NGzrfb&os`9F3K`wH*#zF%1GZU#PTt@(T(U4B&l
z@?6>DXH^3q{Tuwu=i?0-^;`b1&hDRe{!!<%JHgv#8ufnZ_j~OnCm)lOxBY^0x3^+o
zn(ytc&N%OVrr{uCKW4xBO7Al7?<4cSF9YM$^823jZFV1rkMzy{JntHKo2t)UJ|Y9L
zwm4s$H|Zbo4xjZ*P5fi?Xj@PF@H$=;j{MdslL0djYuC1vAD4mnUT>)nV&pB)vFLjZ
z;xX5ffn?zGF))vwH4RJiIL{*GoQAuMO$KTP>e{c@bG}#%)bAPRZ*`Nn=e%^^Wl(DnGLQ@;1Ia)#kPIXP$v`rY3?u`|Kr)aFBm>DnGLQ@;1Ia)#
zkPIXP$v`rY3?u`|Kr)aFBm>DnGLQ@;1Ia)#kPLim273D61AVNCw`Efs@jk|C?m?=J$Gq+&39W29kl_8Q7VkKl?ZL?^)B5
z3?u`|Kr%251NZ99{BEu>P0ox>29kkfAQ_mR0e=71z1j2WvuB3S&H%NNBN<2r=EH#d
zv!#2p<$QL{tjRz!kPIXPqcA{kZtKta`)Cvf(hbV~>V0?~{MmvH11lw?w)Z*K+Z1nKwuV-k$-!u`a!N&i$F2`n$G{%&~Y3_#KgT
zUv8Q&-VO7_$-viUz~A`SW?^w}@Aqr!$F*&7Zkaa(<=e%!3{^!Jt_11aXw_{-6y?B^>
zgCp_H=2%@g51$OoiUEBSjQ#SRSjKP0I(?e;d5+GU^Uw3_nfq4;cuV)=
zDBXiCU0+R-xE#Y7Fn7Z}(_Arrm@0><`Ij%DJB)JzVjPPkH~9>IL(Ew>
znEM>#?3cb@kAaSA#kJWaT~krgqnX$KUyr@fZ*2Z*&OG;ehi^B>+!!#=$o&AngXORT
z*w51a);-yhb?@W7ncIKZKDqw28EE_eb>+H?GS(M*T(kbQ*=)bP`57enrulaJ-*0=W
zT$z-C(idIFZ8bdTjRvi`=QjEHUA?z``*PCzWZb7`psALkt*&9$88Z4s{nL{+<^>}+
zgLL{cfb))!W3~)Xvv3R0!Jzk;)tdLR?3TTM_UPGOGqZg%1_sq3wG`J~W5{Sn#}}}c
z<1Yqko|@+F&F;_1;a~jCN{jW`^aiuG@s_+}4WA?X^Q>O>bLVNROX{eut#Rg`o3+ty
z*T!va_cv>4o=4jyy@oLmd9AshcFx{SIpUwWe$V*lFE)BKXUmZcv@y_BTei8bs3GfZ
zvi51)@2l9&;V=nrO)$@2g|B(u6E26n!>re1f39`T<2Rq@y)*aXGcc$w-6LF2abD{k
z)f}*W@tK+K27`EwYu)gzMm>3)j{g`P`F<a{nB*SH2(-2oWzbd5{o&haY)k?*(C-H(yHaT|U;Y0i>?Ul|xwuWdCo%--+K
z^ocLpE9S!Kug}&vV_)}$Mu#tG9P}3RT=P3v`kU#NUj0?SjW1Y&Q(f6LN*!6ZbWM#a
zsXfHrUVo0GZZ~r=&wfYTtlN>)7@O!+abboGp-+Y^7U{nU`
zZ`*a;R$H^Mk9xL6^n<@{0s0`m{D0HL|GRm|)iJ|(xGMX&FOVn4UktdW-%9!&#(l@X
zPTZ_@@?D#W`NURgmU^mdx2~;O&p#ujk;ASyZR0HVWpw=Tk1_;&-C$8UU;
zi+WGL<&tvb7|ejVnpQ^ct=Dq!NpdwA_?-dw6W6Eb$hy8}J^%eQi*1SA)%|yrc{lWD
z>owa~whP^i?Xi4N#~!fcHt8)#_7%W?J5p<9%UQ99r-s6?2h?t95>x}
zW;XaNFn_~jy?5nmH@nwsGI*wqe8CzriI<$v`6mu^&g>z1Ownd7JFlrs~%cKgW(D
zf7!e7q>F3hZr#GisD0Uf#92o=4{S8?x+9-KgP8ss4sy!1p$s%}-{-a=(!R-i1377G
zWgzxM>uvpaQoCz&ko4Y`pRJC4FF1(3c9`C6@h1ww8H?8-?tL=TB^<>T$aMlOB6W)Z;m7{WHB%ytDi4q>^48|6V)h{!E!c*I_K{mY57D9xc?2U
znPD|Gd0pJ`HD+UL@A=1UcZ-BkHz|
zB;y$d>21lv8QNUZ{y7<-|8)n|%p0%8{_+)jb5lRAZSKvM^ytVNI&X@E!!J9yd&CeT
z%;7I?=Fc)NMw|EXy62-v$D~XKDhB%BuWE?e{H2!PY2NsaRA*k;X~n7UYB?(Z?#q_&
z;T*N}pK%Mz*`x=rxcy~tIj(nW3gc`#7d;0)*Vj{2MF+vahPkDRlChnkmh=5W}A*o)irk4)24XNw$@hcfL<
z@5aTfH#S$!ThDE8llG6Y%{T4Iza*$lulq`zNB?O5O@FVuO}a0fOft+RvDPKw
zsT&Y^8$~C!&5!>sH2v7?gL<>qCb`;2it$~4Ig>c}$@wn}112#BJx4O|(HN*}RCCwA
z<a>SK&;E4H}#C4^x6t|e9M9?y)8-o%KWu$g_sBfS0JY}fx~t?U
zJ)-}8#W?3&FzLJcKFp);^;+U%+bI6_ou!PuIqE%~E%xFz{k@)w^Yl5J#R14Qui@N2
zujljHFY|s`2D){P#d(81tdF=S&FnjSr?%_LeAM0J|hHXgOkkO7#udMrJ^h0j~v6G@{Pi%EB?lsu#^9C&ca&PvV
zRe$c+V9N#IdKLrjawG%uV8H!gP#v>x><@ikYO;Ve>-aMIHk3uKU7bDNJL+An8POhf
z?jGl(=-nzW^HJhzpBPvFnc)764{$GZKdvRuIQJ3m&6#F4nsUu}uU^w0GrK@0`tl5n
zSzr6XKkA=~N8ORT0lq)rd6Vo8Stn)`pQhZC*!*XMW$e-J&+fy6-p##xkk3rk3O{fJ
zW;*J8%*#Igy^21`p43HuSWc28W0HXe27Z1ESzEub126j%Vw%`-_jG@?jPdTvKF_56
z`4?j5H4)dGlQSa0Oh?QY_Fz8%SAEQM(@d5OOu#^?#h>4SYZIBH&%nO8FyP60EeEaD
zzD;xYRZG+F`83i!r{1^D$(~I%pXE)YIEG83-!o^mamY)4_vBi#Hu0DycH&Jl@KZ5R
z)oH&TsjG-jb>Yb`voB6Y1w7XMt!+MzZ(EL0?S5DLH|=eP>{Cmx&sB;)&K5E2{tOr7
zN0J+TCjFV5Ig){C8BiT{3jE!=UOk_7i_a9lFRlim?qeTu&btmeSA4HQeqM|IGu3rY
zYO%)5_E2v3IOjJpqUJt0RjFq8r6MCerbS$k#um-*17
zU)y2Sp7jy^cxTRKS)Vb!Y`r$hJjPF@>x}N5wWNONCk_rA@40zF{+5@RamKj*{kn!v@JYwGz3QX*^CoR)sh_INZybA_bF6to-O@+f
zFiP$iyB~7>ta;h2_v<(&E$4}*)RTd+7*Gwx-t2yi?6~$?68@+9v;9Zztkx_fdh`*BSP)0PZO$N>Gh?$I6D
zzz(%IWcb@0;`Ucf4|V)p4(4Z3Wm}K-E6w^|&O3^vA2xv=3RsJ}eQiTF4gA{r^L|-t
z>dlTLr}t{gpSEOR6bAUV=*?~4*eE#~eW+nZtmPk;FZa(jZWqa3_vrYDv%E)7^#Vp2
z?tf9%JvsK_sK=Nl-E|vd_H{1cwKhpU)|@x${k4Y6^@z#wr5WHmii5d-JGXsf(LeRc
z8EE5oQS9`XcvdqJZKLY+qCs%(L9*Vd!j+fIMA
zj`wkDnX8je9?>x4D?)Y3VzTepn1cvsG!<7+Yy-<~>QKJ2%%>wQ|rdRcdU3gL56
zK~M47T@Rj*Dyaj*IgrGAtVrj-%Q-Bkdz~fz)-9WCUaKYd!-i}_M{5!GdzBqL6tM4q
zFSwU9xEH$pqV)Y!emw@L7Y}q}(BC`Tr(d%Uo6J!9X`5FuZm~%dqmqXoxTj>7#1^V-8EJF*gi<|cND~R0_r@>n|d@c
ztoiqFlrOT=f9bdAhWoGgz$br0$4dCxdcW30f$M|5JWg-!${$QJriqC2q}$5_5-%{r1k8t1i6kL9IvJ%u*R>tzKQcD|J)+kviDSPU?F_`X`KbD&{n@=4
z>4ENEh^*oMT+7*K;+_1T_YvoQN}oLz@N<8*
z#P(kW_i4v_?i{w`pW|yV5bJ7Ey{`9B`mlXsEVdl&4DdeYtLd%iZ%y`Lwz@CYCpc8z
z+K0LOxBdCQvC{v)vr-J4^+jmwpSJsa^drEWIN&wU+w$S(d{M@@Hl5fj!M}MOk3Y6o
z0h{A}CQIAfBsqLHdNh0COMhmKKO6RhBLS}Ogswn-;@}zG(j1xhR;idAi_L&*td_1P
zYKgi4{CiidLC0YC-<1(ZjIkyCpv`@odyhQ*A|CooAf27+dd4?bW&Jc|5mu|NgCgnY-85x_fJkd6vIH
z&i^6Y3izP2hKy)u{I3U#vaH;R7BE(CM|nx_k1v
zY)y!LdNCP&qf?7NdS$mrbo#6%dW7Gomi?GHAK81lr!`6XkYRt%kxen!>{GAXUdx!9
zdNyjmwt3vgK20{SHA#Obtg%1e8Tdos+rftXw*vfL1$y&SkzL7AM!z@XD`cM@g|Uy}
z<2to;%^;73jzBHgj-Pe@o{TmAOs7vrxZd_;-xSt_b>T`N-u-z?y0KF9T}eRfk+4(d
zAA_-vcZ&WuDvm7or31c2a8_hbvJL&%Ib7|Wy~Ch>VjpYMsU_DW@jj%U%B!0d(-xi=3W9K_V$JhF^^tN%=u(lB(TSQB;ydNf!U
zSUVGl2k1Fk7--<8D;rn}fJ4B00CL>=qu@SGt+qw4~`FT!h)b&sYl*@v3z2phtla4nGcTws4{
zg`Nz^%^v93R|Vpb_~vM4;CK)>T3Zu%&!qt75zU#$xALxl5q0L&Lfx-kWUGN+Z6l7F
zqo%yp)GuGP4!maHNn}&cb>6sUThkuVk9Xo8M(t1EcJKB#iga&AMmu`bxR#y0_?`xh
z1FaiZ(m{^*Wx(%CzvFGF2lr+4j&Lbl2=wHhz&ibMO~Ae>VB_z`s4?n>Z{k~#t~>11
zqVtjiPzPOs+^&mD>GWZGGymB?du$Z2@3N5NF9y!V2RJU$bGQbR4*2J7+s1>|Ks~%a
zvFy(rKWYK#bD_IGxfU()Ww?H@H|^zq*d)nK-M$7m-zd^K@wFahor5#_-vRLRdem)$
z1K-`!caM9Zb8jQ|XY26fSoAoK6?-7?mZJ=O&jjLfye|X1>6JjAq(}2T8T?kJPu>aq
z8GKYE@5i6T`@*)cC*bocP-p(nFuq9#*uC~7o$rM`&kK5z26pzk5l#g5Sufa<+$_L$
zD&+XV09=6MBF(M)AaWj~Eq~nqL3>jd?n_AbBXsu_%LCcCOY}!4Pt&M-*{l2_Vhv)i
z^Ae98S+6m7e*1Xd<{x8fAMU`q?;3MizY2TWhCi_Yoxc2B(8P&t`|{ZlwuNyn?9>_T2
zzCH_i+j_KnHIlcdP9lh9&RRXNyN9*OSNV{ex62I$FPtAM(2pF{`r
zLFA6WTOSI1b2q|;a3El#b^&$tO>mF4&Fj=@-JjW$9u3f`!^a}&!PMe;0rkS18suzQ
zKR;^cSX{u-u5cj0kH2Nsu!BM4LF=GtnE!5Bk8k2N$Hji_HROE-uX$hh=eh=2x9z3u
z@4c|Qm*HnUO6oDrsV(x@hHlh7+IIGdF^)xYZUZ0pXG`a(Wy}%v+Ru5SgiH8?>l?w`
z!b?~44S{cVN%#-_{ou0XD)TYMq5KcVj2R<+x(;DrMcf0v+dYAIj^6@repT$plGFor
z_*CSxB(*@jWApEmZ_-^$)>*?Jzqp*cCR5Je8z3Q-cOI`BevR
z6Tx@uIl93+!sVy~p7Fo0V#s57p9|Tj58fJC58j!4M!n9QHJ>%ghhlGviM`D_`?DW)
zXj_!8vIG9E?VCVN`tRkC%vnd0%V0hX_(mV^+hp@vE#vpY`Fvj6ne#57E8GdZk-@jI
zDeM*L9{qpRt4AFj#pZY)2I$Lxcl%RVmwqYmzSOlr{qpZo*v|{-rF<{=JPNE+d#-EO
z5Ry8IzopTi3y3F{J;?7t&0P!B$BjU}Gx%OF1lBn#=iz(a5mto_;j0d~fkR}3-wYdX
zX0-9-Z_;tRPd(t?dG4g+OC9h|&jN4!Bup~AFL!YbTGsjMp5{5RjVKFlZl
z#R0d+0`?lGWi9$26&r8wH((v#yJGX7tGo-k``S0@uLAWk?(iAOc^|+W#KGKs%#wY<
zr9f>Uy%weYuu+R~t=8Rl*$*9m;QECV;Pcjg_OJ7LZ?9W6`9&N20($kc@K7Y*sLzVz
z9N4G{c-;`z1^P6<$Np15|A)|#y>0Akjd~y+nd9vkpr_HF!MSwa4;%G%QS{X^r~Y{7
zC1FQ+6s`s8gIYjR57hpPKu`AXXzGdilR!-YeA$yXCvU8gP0iN|V52J?+zG^RKK8y8
zHiQF#m=%Gz9f3P}V5c6x@_^&r7Vx&bAM!@veR!)lyiP9$%<qfo;}L&
zxvu0--q>f@gW9P_>{{itihXJj68)bo1H@wJS8gY<9O&)*d}
z;0Eq5ghS!H=y#HQBb_qmo8a4p>vdsY=m}fG-}G(#`+)C*oH^c}0s0p2!{15qR=nq_
za3CBBO9KB+M9(`Gcx&F5-bzhSqv(8x)XZy%
z)R;jm=eZK7#Y=%RZxnEDa#D-<5w}&=;y(2rpLKq&yMtTdUVt}%jkg5!INlP;Te-h7
zzZUKax|05#$os?lnLsYy)3JTu}5<*&U`9t3n#*wurBNi9Rb^cz;9;W>s)v!*pTFR
zG~Y~)kHdg}JJX+eTff(>^h;qyaNpdLek}0LkAiEJ?}P7`?*rZS==!0)zX|y8tx_Ai
z!m2>6u(#pgyzEQOfF*%CBW|bY#NvaUI;1Ag1oB#LN@v~iHS1ffeUU*gr6=DOSijQz
zyr3&dKV_{auy$R5gO=_S;_Ls|Pn@=3T8h+|Lp&KKzn&nb8sHNG>}c*`TfF+0-nr$;YIuLrR?-kt&aqp_+t;NAE>ky`@&5<73YFZlP+
zlk{f+>00#fV`Qu!bbrT((#g9fkdxluHdteSBxmFt2PKwx=3re|7O;_BIqYkk7pz-TCmt{v~}oiiK!*}7lW>Cvmw<2b73aV_=vFtAcMN3IKe
zi^l@*>z<8do%ikud`r}q>ybG%1@t`@l7jA`X;k*ETr~&4e
z0&Dg`KPmQ`qT>%v3*hidxD)W_n`iGwfnMY~LAp*}rMoww4?<7tv2PI<=acBv@wjoE
z18xEObCK5J=dyr4?fbz&yf1Usp9DA}9x#6pc7?+tc?b9;FFvf33p<w?Oi8sdfP4KtKn(L46l=>johQNNDfjvQAm%1t)A8Ks9NYQE)D4V1ozd$YbF|z}^wC
zJNBl`dFw~vxd0td4+g#JMWB|@p9I!iPuPe@z826w(Z5xa7}l_VZ_s;X4L|mC{St$}
zW5^xz;Kv$y0c*Y!lJj$C_+*c(GQX6(6V8P50`3nlksD(0yAa4j+@Y`~90>OU_8o!m
z1gr|1!k)le5KHdcqBCb-auLUG8h%@y6x*RBI(e^!BVnxoKlc76d>1wZ_GB;Knt>!X
z$9x%}5At^O=6&(ayKV}$|0(;D=F|i4ye*sxuJIS?)GzW`;5%ZD^xBj3N8wVq7pP6@
z@laqN!27QVoP#-%{rp>*{izxDr)JSP?~yI7it4E}BZBppywmM_v>U*Dy>hkq+Nb%*YLi;f?#ZeROY;`3Vk*b^Pe9*&9o
zvln;d{^;BXUXFz=;ZQgdE(Gp`{ZfDv_yzdv3FI-DuL#S+s<0uDhur(ZxZEKNHxO?*cnM*tUf$fpe2*NBF0F7`M{#$uVCB
z;2oZMS0rz+B=8P@7ycC1G(QqtBiGWYTWUBW_H67g!n5!o5KBF<4|TaOPzTfwaKA)f
zk)2ur%hCb@K`K{k30e}=;Ixo})?EqN()1?=$L5$=RXfmrmOKo0zP2ll}i@MiEzZu~h9dp!&8
zz4Q!v8tYGje`}(@2(01%DiGsXbk?yW0l&qGcZ~g6V;}IXz`dBBjg5J%bM_$*cO|Fq
z<#TprFeeU4%!Yvfny@Ua3fOjp
zTVY=yFZ;tcXV?|Uft@)q_+ujm;7i_3fmqIXAoR+dJst$&82C*($dh9<26%%jf%>6u
zfivlUO0G$63;0|Jyz`Q9ExZV?0`-kfy@F@K-^rtNYK*t#?b)NBqa2OB+@F!`iCmT6
zvVdF>_5}7M*Lgv_9Xa<4IQy}H#FrTEw%-tQBxC_M`5w9|@PjqK_-QX3glmEI4Pi&vD?0DT**67ptrt6U
zbn>F#3fltv{zKq*58o7=A_4yFc_f?&ocUOAZfsWq>-WM|0cS>MpieU3{6QdZj$avA
z37nu)L%aj>K;Z3oBiv{G9bdI1}PI&`%2RITFYVyw8^OrDE$y;sX|S
zz*9uL2Ym77@HuF7wGJMNFYnC!wxB1;n=`)>=vmYRZ@?R2C&qC%(&6+#xD+_UnZS8=
zi%w2*JQh%A+{62jgBbE)<2>x;y&cDyvEjQUEDOZ=Z1{N}|DK>9yU(&G@$Sjb(*1Yl
z)?Z{}AMST4bc#;wmcX9>R88|OZAjk~_JlQIRoEA9g=1k|z>dW4R3Ilgm=o_oZv6Oe
z$Pf5-`F;So`K=S}G*YogMt%D;uzd{l5wTDu5c?{PMBko
zeHSeTt`CKMfj8lO)`X=Zd52xWZ;qtSSm)g?1m5mg;QjF55w-+!QBUN>&R#2m^RsT)
z&YEq+l9T+`La*Rf@=oXqarg}EgMKO4k8_gaRN%g>p9wKP_hHU?cLnzS4C7w+Fnk}l
zt8HFulYb21gPb?Thqt;4;4R?)T;P4+8sL8+@GiUwHr^NRk({w75J$Z2#IYZ-tlJO$
zL14{x)_Ch>f!alK24Y!z7U;q5?ZgAtIRkmPJ2?Ss^l$n!G49vo!jG6E;aIp5R)jTy
zK8n2~>-k;cA;aK2&*Fsmg7e*PxfJ@;@
zAnvB<qPj><5u^B7claW?|Jbjp3xf;5C3ortiw5Zki2h4U>(j+
z1^o7fO@SKNDLS>WCu|AC`Mr2c-ju%hQ0&}`cf1p@larWbft=(3w*o%YhR;DRz#4Ye
z$%TzMK<^c>=c9mRFMPQVlCyE{6=7F67qA}**meZ$+rmHf4e%{2NoNfmJMnxU{$Bj8
z9LvsNFMP=3e8evcaA@pFKNQ#-9gyQd*cXTgrvm4^5iW%j0o$y{m2%z*oQXU2%6!)Q
z%qriD&IjINzz1*1yTA+Y!8>;Z-j6rq{iu<3N#1QuSQRz|YGp~1JlLoQbZP?K{^-OL
z!(Jx>{`k2T(XrvTE%09WT?!Y%wQwhlGx%)-9!f0oR^a=&7s$>1xGVedTf~2#InF+d
z=*#`VmCzMN9dHMaacpVM+ajCBjqDc!+#d_n1)QT(Pt*r*&0A~>yv4cD5e~}yRFWFN
zZ&TP2SZ9te`H07l`>+>t_97pC$bEr*IqRChIx%Mg>+FvY`7VTOfn3Ok0C>RXO5hxq
z!d;P^hdo#$KYOuG-jyO*-z?aWKjWX$$xSZqa3Gur?2Eo9
zoELBh{MdtgG4B@nD9L?@yB0WWr-1oc0ej#>j#&-zv)4_LQZH))Js40Y@$b1-w1$nfW$EPJ6{rhpkv)zC
z26l20vnn{}x^&|1g`P0Y@PD4eJ<{kM{fFI`thr+(FEvyLa
zOWqTqClEt!>Ixrn5kr3b@MjO!$b+4A=IHik4gWKN+~~&wxz`JbVa{1?-;nNDV(`U}
zeUYrOhtIJjo%1XU=>E2ld|!VGu_ymibNco_3W(#byN^vK!2
z8%;C5D?Z{?bNJ-`=+iySg_RWjx96PM}^q4y0cSycN3P^;#0oIFalK
z)Cyx=l340)NpL-2XTNiSb26t6kz2y5un{D+L(P$kIDD4{{IIc3EwTq|*a13u*q8M^
z!DmEgzcb-f*cZsXBM^%}JrtcYaVKK0iez7MkUxUG$ji6$r$E2`F3@xNw)hQ&9UYr}
zI6HSjdd+nGTIr$%idtp|i
zt6Wb4-{?mh^o|IAFGu*iC$e*oafbUcT%HN!fM?!|ci@cx{I3-79{;KL2H2Jb-V`6?
zYS4K@$NJqlA34dhE3hB$k7N$^%Df}V*{+0H{d>Z9%K=y%0`>LF2gi;;QNNA@8X{`fh@(z)Y0Yw*LF
z;f^_6aYydTzh^!cojn15+?~621n%!~Ed54!5{PRW=d#lW`R|;+_xP?efEVFjI4R&>
zyf?LgjWgr(Dlk?gdGq+^4DlDm=6)O{ypj(I&(sv$AC@^a05&uyKWpf#WxieJ*tUcn
zfn0D-4sv5N@B{YYPWuABXTrJA75Mj=Z-W19`YwGIgFJ&Ui#-PA;JrY6qe1>3dF>C~
z13U|t0&mJ&ZWY~cP7MIww;uRx3dFdUs4e%CC+V+3e@IfJ266UXmhN6cEI#yi!FNT7lCxh5cfzf}J&;|2S_b6f{96L?%(>gSz_)N9zz^#N>y9Oc
zIpbNjgAUjS4%P(t@Ejj=LJYp*dv}YDycP}x
z{E593h~ezS!G+hj=d!>V$&Ca)SDf1q8#?~v-xA1!zFy?Mr1!COesVjnbHNokiRZ4K
z+mBf6aD)vVe{!+5C76px>E8tE;!-#hP6aqX?-t;P&y(;V5PvIR?+I}bgWcm=x_i3g
z_hdU4$V0w)4RQm{#5uSd_u}ja!nUv`>J4^`MwLB6B%(`&EuMN
z=NcyQuSb)u_VI6a7w!22Hw)W(*uDeMSwFbC8Sz{h^n
z7z2q9b&QT=AlC)=R%#Z+x@3)>4ESyJr-02dOC>(mKmF#P0+O0v5zyI-J-siI`sSY8
z*}dWq>ENb-T0ar^4mkh0a9s3N$>jph;`1ZngFUgcKj-jSkgO4JKhKfG!}*TDUWWp9
zz<%U|1Lq~jws0iiOAN8-tdWa#Y?}i6vj^aOIOL#Z8&tO7;Y5lK%T3(6e8Jd%aUl2Xu-ZA9B75sfmeSRXXlbI{;C_F-=ZcjruS0blU4QLrir-$<|~EDI|F
zwaT2k9}9=VrhtunU4cEg_l_G9id>`3Px4+6E#Il0fRz`1S&>b)ya^F86Z%<*{?@H-W_6S>JpUiRj!%*o3-
zxv_5v_+n$td)x0!wo?Jg{#OF~+zJ=Mq2PU-mmJQ^I`eITv#@VRASb!V(-pW2cVHht
zZuUdo2;T2bI`_x-N#Lzm<4k~DfHn6^a-0b4$Nrp&{q6<(y-25?$?e`w9(>3T$oE_%
zIx*Bfao+^KY4X;?zrS9!Mm*rp7TcpgKCF@RLExSSXW$N;zayLq><73zwoPG4SS|Xt
z@s95&8EJbvUL_nyF>8^We=D3Fu|x`f%Sa>UUr4U
zqLUl_SRmhb0pCr5y^JI2te*&RJZR1xiR%g6n>REcaLw8P<;@J@r-Ab>qU8Ib*8T6g7t#-eJppd1qfyY2AN5MS-|0&FjX>Q#
z3m)WS;MWtVOX~1exD*bBBY~W}5fa}M;k?YT;m;oQ7w*7a?gjRu&H-!W=6(!prco(ot%64?J(;NIjR
z_l0m(;C#;gBs)3ahclA@QD86N{OGU3H-T@LH(~B?ocoZA*cV}(L2mfsoN(u}avshP
zIJbG>?f@IU2f~i9F02VF!nSZMoCxGa5_2t3e>;NL(TUp>HiRt!f7bVeLxC911Lv+&
z?gKaL2uj6Bwd(Ughp5!7AXMPk;1nvw6mjbzw;6C71Iz0#;;O$7*D%h3W5%?xIg;im#
z=o^yw?F$D2e)v0PUHW#JbB05K{Ok|E0Q;TL6a42a=Q$O~$-cxf=RU0A_gEz7z7epa
zg9qVWz~-|YNk0=h0(%m}Ij)QJIyTl$izJWF%AV+5fql@Qgcspe;LVYKQ`W{E!~k-0
z58&SSES)oOCOGq*@wc5d?!+CrD}MIvNoUP@nZu>|gdf(JBjMzr$YaTKfxP4(mU|=F
z6a9OIVRyIxAivtjbIxEL=@D(w?)6&wtvEk;75M(98GeIldh)Q?Y0mf7vAh+4mq&qm
zrIuZLmeeVA$G3(5iQt-}*7+vz<&AhZeA)*8`5+iHTp#3#byLsdnsxG8xAb0dZXHQo
z@vcZ}jcVWZggB=-x@cLaRw
zi{EO&nk4f>A)be`0RCKg6?i|^JHmlLZ#Waq1VeZ?FqL6>zx0jNb+0>rvmxl
z-a3B7kQY0WHSR+^wtIm+UIc0a!11#HZ<$HH{?KtMECw#tkE}kV|2h-@N=F!>6{rG_k9w`4fs~v
z?_Q<5R;Yp4lUQ>fjP*edV%)o^GuK`8o2C9;dyE2j0`EOKIs-N0^Ne!#L1(Vxqc3~Z
z>z;exevoU|ClY_Km85W@+02FwN*>bTHBiD
zO@7phd&;A9gWl!dMnB`7?+Wm7ufCT~?a`a42|!&_>%^QFoJo@BQb0cyShFM#wMuVu
zetIrBx&r%gPWqyIC2z*wfctU=Y)Ig{IgT?m@iNFZ>pJjWv(Ecb^7($qIHG-2J;p~p
z=5{XXBo5|Y8&^`p{JD*s#c-Z^_2QsO{s<{hQjo
zl|Dx=bkCz#(=YwomflKFr8iOo^i1TQKs`PR*fa$@Wa?X2rPIl|HWX-;{A9Ig7j=4wFqbk|sl!#$mwFHP
zXzG}LPTo47?=gyW-Y7?jOP|>=5P5IXr`aXubDn6k?zLFkw#DAedhC(*nWc>R-&%KX
zww&d?K6@_L5^~-n?lo_nnvdT_+kS0#wm<9WlZ=>SlK707o`F%`ZWN#CPx8JQ-nu6b
z+K)e*a*WOZT)LOMN3F8wD7`eEaa?_LHq!I6GcZo=v~l4aUT01Xdw9J`HuWyY&003?
z_1-r6bL48)cmAyT+TQIg@7q+*v$W0gF2l~r-u9X2IWqTO3{caNbM!%D)b*H?d~r_i
zi9N`_7m=KYQQK_)u{!vlZQto4*$3Y+S0`b>?;mS%l037B@fk*yv)D6pEH(qw3d8cp
z?AP9E+pMMQl)UKlXFxCacZD2f*x&u$^F@%p_bB&#D<9s&+`ZMFUumCM`(NqadDq!8
zKpnLW*O;aK>N$4zAooxEM!R+Qg(m4ZBwGAbFE4Fj=%TK6|^$xhaX$x%-=EYC+>AN78-_8Z2B_iOU=TFM^`G;xG2M>6oy
z7^rL2JvyGVwlS~chRvOCnBPZO_kE+R&*l51Tr39i9T)4p^0dD*P}lH0=Jl?F_P}@0
z`n=ah*}uL|&Xa*;AQ^ZM24>L@<8RYx?hwyHo;aU{KF!%OHW^3;l7VDkI0K{f>fu?^
zBN<2rl7VC(8At|_fn*>VNCuLDWFQ$x29kkfAQ?yol7VC(8At|_fn*>VNCuLDWFQ$x
X29kkfAQ?yol7WxNK=1$l%hLY`zh`$G
literal 0
HcmV?d00001
diff --git a/tests/data/sptrungv.ll.in b/tests/data/sptrungv.ll.in
new file mode 100644
index 0000000000000000000000000000000000000000..4edf2f77469e6cf401d67dd857bc98717a9093e5
GIT binary patch
literal 212424
zcmW(+cOaJU`xPlW
z@_l~4KiOZ>hKoG_&CShBuIAnq(aOtlY8WxM-+M@BWnm9_krahzUug{TN
zN-Mpel1a|x4)jLl8xz?)j+r>JlgA8cuw!!Rtj+Wj>^74p?3Lt3R>*KI`#ta_uUsT@
zz%;3xc`mF@&EnydVo^!={~aTry|<}Y{4>dBkAv%7A&fl{!_+EC42np>UrPe}eu`jo
z?0C55jL@uOPe`uj49Tq7M;~NT>B4i6(2o1eX{QQHiNoc*@G@hTzcr85UUz{l9=yhi
zq?E8b)fcjrYdd-Sy5%kX#?CW0lFZ0UF^Np4G*OAtAdUTgOxXn^wEFpYjIxt3!(9@a
zDy30bAdUX{lF-bZg!MJ!A@uSmUDSR|r!-H~k8zDO@+g6#uFa#BYNr_w*Yg$?N`1WJ
zy;iK;hBCH5c5y$H}l|>3pHnE)BPI_)=m=h$qy^cIaW2ntdsRa)?48aJ3A(dos}xePH&Ur{rDEd{Bf6|?`Qp~
z@j(f_4L(BEZ->dr=nM5o31EWjBwTTjLf0=DY+Eh|t+leyk(P#jlqkf?#=~svJDuHh
zp9<@Ev}>S>e6NSo&GPB=a@8KjC`Z-jb_fdM7A^D(6ApL8YhTAAV3QH
zW8~mZiogLyRGgNFN%~~SkBMUA?D0rm`jvKn9;U%HeRS_G_~1ym^7OO9T*$SLIu
zeb*n4KyNX8b&LrP+>x+Q>@9iQn_z)gz!(nG(t=2QAS
zcdDGuN0pOBnFG7yxwF?{dC^&{kK0*R;XyBZO(~i^ZzReFuN32*3y)!DUYJ5(JwnOH
zq>7Yov&7r*h&G@2MFmeL;&7uRvef1A)^#ebYAd6pQ3-!9C_=eX25Z#BV7OiYCm(&J
z^#`tzuzM%{{+mS`YaHnG(^pJ~{eH{eBh|dFgaz!q$Rc*|`&D+@)_v@;xt=U9=PB>*
z8To%4+k6V*b^+XXprOIG_O@qZhWhn2T
zg0^w8_$Mj`ond~c-G5KNPhO^ij05y{MLM;%5!nq5F+aY%w74kDL
z%~vXCYr_|@TO`|f-XZapR`rh={Zu;&?#rV72c2|L@CHQ*e<8l7`)I
z3FlQ%)}e}(7Ao)woeEV1e@N{VDm+qpR=EI6O*XR)0n!1dYCzXU-VBp
z{*X7nV=Wu?teIVsah82?Yd0HwSBsr>J(Rb*LX*j<5TeuBUZkB@LKZJj!WxR(KA&E4ZCC^SSkwRt>X|yuj$d6bEN3oNbAR9
z>HVRZ^drBFiSunAC{r5atz|-4pQW9w$BRBz%4R1k79`4An@!+ddXUWMcBqoa>PQ-I
zS5M3S4N_SBODYf=hwpi!SoKgA_a7@EF-Hxl&t_oPof(MQqK5wtDB*pHELNI|VsRxO
zGMZn|y2qz!jc^_9D&IC_GMU#RCdvNIierDgJjzaUZDF4Zdb4k=pYqbK
zyzPHA@h}sVJ)hqHNTKbI+o=EU6?%W<6KUuRV$5C=@3a(=*sB7s&oi+0q6UuHYJmKw
zLw%+){^Qn9=4x`!sxh*D^pw`kIYC;xDoONSAa%J*(Q{)P=HG5tp6EkWc0qkQ`@H5f
zD>+obs=r&z>Poco#_|g-)6c(QFvo?;RPyPU`(e6UaF;H&j?!fdVaRgzCU3P8yd$Th
z%TyB+E4AQSt%(T>XFxtf8Rxn4Pc)c>AGUw##PdhQ=RQDtPnXb^fpw%?GoCgXi!<+G7|7ud=*+3cwiZMJZ2FmH>V5pyF?jOwcbNLQzl{KGrK
z%)~IdQyx-LDqvJK;IL5}>z2>N)CXEPI9?qmt}4TxyML~UB5)D>L(+Zs$%7*pb+XTRFZ+A@
z=eY2gR9j2(eVRcxA9a%Nr(5**#ZO|LgfaL-270Tfp?9+eboF#lkfMjs7(EP$>A=}i
z1N^enU|Asp_a_`KzWzalLpMpRvV#PsJL`C|
zitT@I&5~v-PsCxbWz&r>OreWAbz2tEo%DX{xc`_ife$ygi@~y60RsEfu+d%{*Ru8S
zI@ACU-|8cpPZ#n%8i8o!A&3KK
z-_tPPd75ETPY$|UNT))E%C|3O&L3URd!;**jjhaK4Q{rx+ZX$@R)3!J4!9NdM@FA!
zio+LCXlgdum-N!)f%~-M;$QmfD25eriYN}9f&HSoh;f{ag<5maSuzJ|HHJtbeFVj6
zqAO4tzQWS54jm7X)o&>C;AsjMsiLcTexx*UB6*1mF?N6Qc}tWRurDo3+0TD!*iVsm
z?6l==ywSpgmN-7j9DBH$eC5jMdBh1i^5`XfDGJC3!k5VckUaK+{+o52jjJ`3#C(py!ZWA0Rn}Z)@fUBvR$l0NU7%dK$tHwf>lhhn7Lflm
zM|#tIld-)%$3j+Zn0N7=CtLlsl~vlA$Yw5;WM^ytH}GLv5wk^P7WoRM(8u9}6ntrz
z6c7IEn3a95hDFL+SJR*z#l^`nJr)-ZBHc_tiw^{iz6(lz@gb
z$B*7Vpi@=7B(W)r!Xy}a9(tHD+~YPNto55$eI|_E72U~RJQ&D|kG$gLK1O8yl~>^j
z%iDPuxAt19=Kf>WJn*75jg{0oB~fqfekv3SlT9B=+Xawo3Po<~i@dTpaS
z=Va;U7E>lmHkKzCJ%=66FJfEjlG!KS((IPRv4PJnrHo&<5$$-LM&B-V)BL;lNk5bi
z54gT2RAL(RQ)XhAyXRt?P0@700{;#%m^O>S@LY5BUo-*#m;o$@)uH68fM17%@qO?M
z8UDLK>rqERae?&AeIi*{eY0G1rIz>F%$iLpsbNPOLRfjB_dLOXwEn~$LyXr{N7DPf
zhaMQQ6qx#oGJFMb`GpK7&6$ojruwLPYmBw?%~7gI@J<7ECJ^FD`=_J8mdwF!W^FHWBG30Y2F6gmFyeiM)sPv3+p`6$y0dK
zXIWY^j&vRUXvN1GIv06?W=MafFdGpldMn~CG;wNpHZmuh;=^l8Ombd`CRzmBV}SiB
z3!Ggy58;Idu#1=h3voGI3!4Dj&^I*l;yAT!FCzYfODN>#HAe03w0=E$!@FM>%+6OR
zX3t$UV)Meb@@g&ZnW(E%sn;r&ww!7u-HKauJL*5Gl9#}?v&tx4po3V?xmcrNj0Wp`fr^825(G8_0;JQ
zP&L5tm3g?W!eDgVVswOB!_3bb^-mY!<~vJ7rp-ggNqszNQN#SDli_rp9}deNQ@8re~Z|LQXe($wh6eK|3
zbOK4?V?90EeVKOB2vr4(;j@e~7IXaOYLhWGhFap?rNv0^vxSbHJyK@a!Lrs0m-aL8
zv73jIbUn<7R)ODaNqmm}OHo^I(ebDjIuR8`XCBGWCT&gTt935#%OJyseJo`=t4!F_
z@1l7)V$X#CQKqwt;z?knos3`HrJRp^s97P6^~GwKTWWv~dsFCE0Fv=Gu>Ne1pyv+w
zz1kk$E3NVTDT4_9dDw7T7qaHlusKQ`ni{_-!Tc(H-msUx^=_o+If5kj{j}x4!EWB$
zrOR0D-VC-xR*~&%73P(BRWQd_&L{I*SycAqDD^14q&d11aCnwHdIdG{pu`Ashs}}S
zu^4QaH-nc+XGpk9VVl8D|
zd&iW0`(|NuCE9*BSMsrR3;XMlNk<=qjfxJY7BsRo|zg
z!BYo+5=@}vMDTC7L1L97jz~L0Q^*;2V;ym4hYkJ;5c)JsaQ5R&oZUPXr+FesfA)zA
z%m;}*T0(=G&ZK(h0`p;-^1x5;F`k)oG+Qz1!4`Zx#+y>!VL5Z}c*=_krcHYrsd(je
z8qxfZmT!`TaHA@oH*jxyg&DM37hz+eJ^ZvXYeG)7(Vy4
zQTtpGbNYoa<=0!1j$r96*E5S^Oa!gROXA6Ri+npJ$1%9?*OV{e{G;7N?LV-^>w
zP>fO{$v)|%Codk7V~hZ>RTiC#G+=bo2r06bkpFIt!1dgjuXM$?%S*BQlq){YUxHpE
zTP#1yp!d;S{Akz0GfM>&)lR^J2QSDZ_6XUzXVP>dLpt>`omsHYgtv2%Cd=&2V%w#a
z+1!^>yy;8@qq5wL_CC&`o__;W;rf&4le|6NL10vWB`nv=m*iD{mR}
z)7;SXXDK#(T!P2`wpbX-V1evh><-jK#V$DrgmAno|1nv5bd$Dc5>4t>qlb^3nLR3T
zykmT3?9_cRYPxF2_V0Nzt@uIz6vW|Yqk`&%26*(t3A~eF({x9&f*X9&ov}I27R^EoLTAsxEMW~iZj?cR3P0}2-lHu72dFM$
z2Yr1gMTU(cOnAm#-g=QGtdY(-)*<#ty=`Z_O^3}p6E^MhMd;KPR{j*}rG
zqmE_uM(BQFiTUSj@zBx*6BaDT@tzfsZdn20smpOj*afS0*&-p;5-Saj@IHG6j(2m~
zU)UJs1m2{{aZNPi`bLWG8b|9X&GL4^1>S(C4_iCLup@10yjU44MxsuYUbiOE_JkgK
zQ2CTzzYv5;hyo^D(uUS26U6ftqEycjV_M5_tZ@aZYFA>j>`KT9xFa#t1%>NvG4zhZ
zVtGSc`K^ZK`y|01@tgdzE>p-*4Q(D?LuI~CnSZ4lk9nGX?bXXG2+ot0YzY(Nu7>vxahiuzY7#l`!`D(07T!Fr~F1UTq20UMLR1_J&Ie8l1TZ>}H%TJVGeUieT!PaDPi~
z_m5FuVWF@6+WkRiw@CS%OqMArA+auvzV@v#k>n4c5G>#CM$khn|G(Rgz2g@r)f$B
zv}xTb;(PLi&h(0*Xrn5MzRiY=DZ}*;4tU<`hPWfEA!_9XEh`_S_Ig9Mavfg&_Q2%3
zE(o{bc)&7Kq)Y1H(;fvp9~qC5hKKYnx}6TVMUnkEQPTW+$+G;y0B5{7dU}%c5%&D0A*0DqOwhpi8e`1Z#&N69OCa)h1?FY115@gQBza%t
zOjr-~4W2MuxDs_$E|AT%LYTsQY+t1fCO{6Y?)-S2c$;ienyL9(AiYT)Vcw{{vG5Fi
z$qQ5pVpZN>=e>1GvRpSdo)pK2Q>1(wT^D&k=>_BQyIcVg$vT)Y-wfH6HgKw2iZ#Zo
zp>OAnm)CvKb=eQ!%zUv}!3&|AR$`8=3qE%(22PqFE<+Pmsxsi2j?vyZ*XX!UEd`CP
zB!wF{n2Ia&22Q(AWDDgS*rbkP-nM2FX1kagJ^G$P^>6#A!{`ltb`SyIH)VK6%)-*6
zmXK(7fR%+iDweOq%y;W?<-0#JLjsWR=7)7{UMSeL631^jL-@oZ^ei(*ca1ufSt&4u
zzev9O0_~G3qpCqWO4;7QY%Tjf;C^B%dwh-_o0~C@cif_oS@O=DW;pGk{+dC0WA=kg
zzDb~P-V9{9&PC14MOe4r86Vk|$XM%*Z{hwJ`m+HqKW~83GJmYq@wBcNv?
z?wy+h9gcTCwwAyY_8Vmgo+j6VeEM!-N>$sk7`f**yuDGg+4Eb)SjoL{14^9sdcW9%
zTr+CP)bu(<qQF4Zl8R5oy0!wA22siLi06h%iqkfZhhiM`GsB~NWCuXbf#ugc_&L|d`bdmiw-
z1Xo(_AIE)r>8*6XaLyYe5-Z{G*a=dOgv5Z^FteM6dSMYx3wuTTm3nE8WFno{ktfMX6Pcr)
zT|C=(SN7+H8lIiL9@7(|N-?dew4mcCO_q31e{DqJ#{GX@ff0@eFGSxrXKa*Njimnd
znEE6TvJoNJ7QP92cY~qOwgG%!z2VyJfph#$*!sy5IynZI_-iVjT1`Zb$`cxW+D=9a
z+o-!%kR;CsTZ)X`<6W~eVh?-T^7;?uGWz??>5y?DJuW>vh
ze9mN&8!WolVZ#%D?mYxUv^bRWk~SmjYY5DlK)m|rjUWpTIEpyJcDn_JD)bPYqlk>a
z@u#m1A_ij3-kiJXrnama&=8tTa0?$=7)ukf>9E`1!lX$aqv$VK3@riyHpS&
z2fZ=;*B!BE?GS5bhTtG=T;D7MyUYL4w(A#(r(Q~#-xkr-=~c|0tFw5~hxFL}-}m!e
zQ&ku}QlXzy(`eA3pB~nJq**HB`1Nu+?q(UIS*HoQ7H^0{iM4cr%BEvk5=XyQRU~&jQNr{
z-q5r8oVT``$ETRdblhD)uWuI8X}j~pC;f-c{+SFZA8qWaHG^oaJ#y?k;GD7^=~lt`
zy*&&hw+*K9kv9-QwSiTE3AC=xfZ0cJ=!kqKKA!=aG&P;(
z-d3e54|T?L$v&Q3v?6<=`^3OI`9a3r%7Y>!>S@?!m>fC;V0A_j-RJeOs+Pe9BWH*P
ztO1{H0OUeK(W4RpYt!wB?%t00+-(?tbqge7gD_O@1-+$iSX*HQx01OqUZ;k06Gd^)
z^9?O{euze|$I-+7~gtcAHJA4%`pN{YV^Qjqp@NXG?~5VyP5aY
zFNs;Q(~NHF7g6BB3v?sZ+$N3h}*II(VzH6}8WCMKDx8RM_cAVQDg9rSv
z*zqO?DF#spy&Z;+UjosSz7D@TTrjeWuxye6_Jk-R=QuwGtZvZLRn_G8-HE;jwlTN1
zP2pj&Dtl4s?SS|cmQl1`LB{{;>F?v)bV67VPYz6l_Tt%SKd=x_ZY+gpwHJPlY((&-
ztvDwcjSaoA_;X|z1{7nFaw`fgqhUCo83@1Xwb)|qjPpg7sA|^5qe3~X`}U9eA6=x6
z+QsB7W={D7DGbdE;qBkg$C}3WnA=4DVR{~h(}eC03jO|q=9y38c!C-#dW?~J$OaA}
zE0BG{7n!x8*gG1DH+?(73yH(8mN;xO*oAJN9T55(hS$P@Xe?cWPdq1B6qo~gGvTs#
zGTP>h(msdNbp1T%&tIKMozE?qJ9}z)y8=(}re%#;4p~ek@fm3}u!Kjm-hQQ+byD!P
z(SnxD0!-cS$nnP2FuS|~Ds#edStJ^1>Tw7Oi^ouKJbEU_;m@@lhp!#Ja^_{@(EAH*@5aTfTEwz;O&{Fwmdha!!((in-PU0mJk(E!GU`yA5
zH+2))>sy2SofUsD?d@S?qtQucx4oiM>7uako`GDA`LI4}4>O_F(EGjto`GATvwSBO
z--w5GYa%>nC82RmB65x6aUwbzDkEE<^1%#+Vg8RjfLW>Ysj
z@m~n}RR+j2P{3|JK7`-7Kzmg7&;kV`I??IQs2i5@_MDo|yZ-1PBVV5IgpH?qbc~fIR(0xlOTL29viv)
zHzK+jlOuevG-4@UYY>N5y71zc#o>#i)OP(OO<9&nS`$^M;mLT$z4sJv+;Z6g;l>Y4
z;@8bI=F~~s+F#SOPB9oOYGA=;GfXab!qwPySk51USK?6!vW>^s(Im{ipMrUNQ_(7$
zid=(aSbvMhEAIX6GYrKKS#O9JxuEyF1xkmsvA%o$(o~-xH^G8)K8*)UN)8r
zd=Ggq#tv9cpCn5alTt~*fhAEchx12B2G^u@v2X&XnVne*=>_ZY&UOou@5aFUV*;kC
zreOHLR8V{xf?88?ZC5hf$Ks*O)t}8~o8VjSiErgguyOeUJbkKxaxZawzx9UX(M21=
z!l?J*C+142@Ic$7DxO#GGR9th4wWPq(hU6}%54~jqs~+C>Gy1SrCUMe(F*K)5`eVr
z5%^^thmO=F$V8^%n?yP`JEue5I1MjOB*XY`Jm%hvf}2(d!UWerDb*2LgYzNra5~n$
z6M>!FQ<~JXpEU1yQo@Zh%#XHD11AQ|d2NkNO#Dw5YJXWzH@@AY?72daPEm!$RTJ3$
zvWL&pHLwW_#*^GAgv%trR3-&OY#KJnW}s6d0}btIU`LYi;C(#C>qWt9bR&%1IE-3h
z4{>D^*sv;4UN;fNT6c;6Z!L+wcci;I)r{`8CA@}Lkpq${FPO7Un`pH`C#6=sp?N*x
z=xotMaG^Pxm%HHb6>n6(-;9>LoyfY$y}5!^=>1KHzE~!{9nZjcrF5*BmIBA2c+~iB
zM}1omj;5|cs~D$wt(t?bbR`J)3BZ!`X?zq*=}n6%@dh_CKB@&g+kiOB9coe}E}KHq
zYglU48zDwh7EY`lX4x!+VbyZn*yoS+E)j6*kAp@=G9o6VLrO0bQ%5qP>Ys_3JJQi^
zlEQJbc!(uOLeC};>NOlc+h>KhJ7;s;lgk>7j#1t5bCf5NOWBH=6g(!+JnL=cISg7b
zCTX+Cd|(ebgbvZ2CHz>GIu*qyIW7044f3z8!upVnu&Rtg_ud337^ULP#tis5?Z))$
zyP@-6CWOwXqlZ!u;U5pT)NPn_n!78N?l`Ek2zp$vbn}`l=DUoNhQo3Cc_oD|7)z7L
zgcQqbm7PB_uqCH1r;;65de3c=#G8knB>&rYdi5gJ_**B
z(lF&zCPclnpj(>-zNFnKo|J(A^AyZdj>pcB2rSp~2Y;L!KIah(qjd0eDd+JxPAj!pVNw`1)WeVCD*<*>pw@Xp^*B1?)
zTTwC^ha;{j$XuO)*Wy|D;Gc~d-q|SlyBilQGjM!n3J#o(L-D+=n6}9m?KVqc{Kx`o
zu3ETxL>x1>zUH*$cH$ohp#I<2m>P+j1N*I}S_&Nyr31rBv`?L-*zuz@eVQC**cu?z
zhx1OHJ<#|q5QpYO;p(3RNXw?--2F_LI%ea`x*YtJ&cV$MS*Tc_!STuzeD{n)JBR(T
zoCb2>yEE#g7eHH59rr~hVG$ma-@``wvBZszxb0)ABo^`RAJt%Xb9uSW_5#|sVTh*O
z;744k5;FYfVui9jDr?qq7`F-Is&;akLlVwjNXH|WEY7pY0iRti3J&F{E)Qr<1dh>YoAKA4zcB76bp(V2qfoLPCudaj1*f#2&=C|W6ktr%#_Q7U0)7@1PT!SaSxtvD@0xS9xPjz5ABoL
z=)aQA`8tUxl-rJ+Dt`=KTZ$=H%(16i9cQXUP`~N{-TJSV<_=hs-JC*Xbh4RQ=Bq1U=bB%o))
zgxr2;`L9Zi0tRyFdHf}659NF$r)l_P#`(62OR)8V57dn!@UA2Qt31;2;X*d}-sVHJ
zr4a9gi@`s>80$(4ao}P;4C=EHsh$ptRS6KN*@|!tAAIm~g5qWqq;T9_CW#+kc3+^5
zwrsj>r%ZVVj#wV|+sy2HNmO~Snu^
z#N6ipNX_>IMVv{ZrwT%Jf#2O+VEthxUcie4o*bYLF>mRmqZDTE)P?oIMNmDn5)11?
z;I6d`AE&0`{n{)HF3Cs!i$c^-Ey3CMCD^>81V`2sA&9R4CvCH_!ZHnq-o=4AvKcnC
z79}Y*NN<@1*&$ifO!-c4B>G5na|E54^MVm+w;t$PJj&#Jk0qI*ep-EPls0Q{If(xZ
zQFO%)M)98T{2az*#1in_AsxC)a=`vqfT_;K5MWAi`fMpY-j%?=xd`Ut3s5JRjk=yx
zn5e{Yb#W7t_O8Odu*Ddsu7^XnrEu5t9UabXr~PAIw4=O_N%yL=6ni(7g6?ONUEM{}
zP7%PvkJDflJRh$ga=o&aACk4VL)Iq=Uqdr-&oB>rDhu)7{t_&4E93geGSqA?#fle2
zSpF*?FS@e09y1lD>9LsQ9}NA^E1+Zryhzl>@C7j}+5VLNd%2eyEFGyLD2vIDTE?_y
zETH{bRiwD~9!)D0!HZ@MG@Q4@o4dM7%}x^Ixae@vw;RZ;rUv&b^wpe&v4-c8?jT%d=M0^r-If|N*89N6iKi)#aL
zWpoFk6jERqk%jRo+}TqJPL`D;J*N_lQ>rj&K_!B}mSL_{F;<)9WBR>J3>hUMrD7Xa
zM*48v+z|o!b5JLx2-EeyNNPqu{j`jx3WxVhYr`BKXfz6VE?0
z$SYg{2eA-jDsdcUXBs>zadjzckxRRLM8K{`Zyh@IPE7kEfhlURw7t+AsTG8aXC>GYo9%!M4xJU7{7pW
zcy`RJ&*JpaCW9N{zAUC%bi$`ma|E&sJQp&Nbw+P2_a$z+k9iP|7;pvZHyt(g=>-VS1{tPIX5N_3qK_X+Nmla?SGy+oz7W`%E3w@)6bs_wp)orHsLDf6
ze=#;BR>1RRHAElRA~m=UM>1;RXI>2{Zv7XVir~$c3kmBq*p|h@%r*$T?q%p3Geex6
zDwcK%;6&GXde@&pwJ{Qu`6iQ@@9j)pJNMB&&DZ37SPFvK`q;761||-kc=ly0HmfJ$
zcgb!foh?8_V<{xGtH4`ai}0UyxMW%n8}T}rY^z51wsM5Z7s1ab2bt@+^Kyy7!Ce73
z9OeQQ`+4xvxJJ%VRMBqCdxbEXY?Elzmvxcu^)8s&LL9!97ID|r(QIVt#X8#CgE0cojZcZb9{x1f*Wh#I~#g2>dNYjC3`aQ+1G?v=>{S?!|uFz4%~R
z50`V*sQ6e0$-{dfZkUB*{z+JLc`M>l)**PZH7*zFBG^y@<0n3)n;vzva3({H@;0X8
zj4jn`aGLjJ&Ohh!xsSebUP7QPPTcT8Zvm+cLaLsC;FDD-o=x;XR*NOZTxURB
zX#$5QL-c%Z7L^)E)0s14%(0pza$hw_$G7lf=9mgxdltYad^vQu9>Wdsa6gxU(=r8I
zoTvRk4nM2o{#dK8CcKpo);d$xKite
z%xh+_7FEHm&~ZpIJ4K)T6UZg*Co_0Ql`5+D(6*~L$>NzXgjBU~Ds~~(J>>Lh<#3dX
zC82e77ET6o{BmXmHw#b;LvHWdn$1YC+lP0f&6s4|gotqs$n&kn(tuKYkm0y5r+bV#
z?!qkBKxj>O
zH_r#VC87{=IR$5)=HPT^G1?5P5Vx!zYsH)JaMeC|%-s*M(tR+`Xo8Gr16P}?q4u~0
zvD`bE8kmN?O)>au;188_Cu|!w!tw=j_`ClTC1w(rzc
zsQ@WsW28TJMq}&-JpB-h>XdXualJ&g^ko!czxv?gEj!%oF+l!7DIC1~f*O7{&<>4-bYbo%COROV
zL=;ZZwX5SW^(B{=(l&?bc6ZozZGz$&jxc&EbL4-eUZX%fa8NDNvpiiPxOgcz%*K!eh9+xr7*c&)uUPre(Cq
zO_!XXDUf)69x3%-r{LAXu;9LZgyoaapVit2yiwO3TK2u0L2L!{NT}8g9mCAu@C|(X>Jc
zyGyT9oLde_&zB+d31+mqsg}a+pV94MNnCa?z{1CNC=6eZJI{9D;KVd^1?3?mvy_|D
zsX@ZfUi94A$LYtdSX|zQ=XPzVif@6Mbu<1}*26cy64woia4;?l4~h~|#=ixqY#4gYF-(bz#5ysvb{S^)_gjB%*m1*NwFkrf(;!Aluv
z`cZ%j!{t!-uY=#7CT#L(LBswwn5P^-$eT9oy4iyMCCyl}rXC+BR-#~SAtr9zja>}q
zecTG+G%7c|kTZkK|7jhLe<}0WF%s1YBfi=POwz4r($76k@5RPJxLF0l+sv`ceFc2A
zHp6;-BDB-9pcGMrSMpUjw!Q(4j{ETSY%5Z(9)ONdJKCcT;J0Ece%dr+-K2U%Y^p%h
z&OK1I$%NNkP8-MxLNB?(kjq<-wJG4hs&CXP*-0bYR+HyON#aK~b@^PSz;+>+{n3Q%
z)E-bC`-7nAf8LwX-yMPHSl
z(2qruP~hesR&ajQ$uwX5$c^E6emc0BD%^G{M{8IeR?TZhYe6f9W7~1<>p^6{KM2L(
zc2sO_#XQkwTwG9xI`MJ{=jY?ujWom#MdNbUdQ6Jp?vtH9*9S_V>E}bLrV8>j(5FMQ
zmr+970SY+&nQSk}WBE2?#BygfS%4OD@VBB8|FRu1)PszjKlvLd9+zurbFZ6A-g2pW_*TnVF*OG5g
zka8ZKDU&7Nm0QW~!yNn0BH^^&sr?S~>5Rt3R`9VH;kG*x+2$>ZBktCIZ8o*FbzZQ0}0P
zCEEmX^4&QKxSmX2;S))rErZw-L$u-1M5uRYqPJ%eW?xu`k3*4=a!$p9%shBzmf;Ok
zheKt}NXlu0mrMu7)VeUKy9-X|I&paYL99$`g$mPzy!;vj<&?l+aSnRfBxLG_!E~Po
ztd%WbvR?%!xA5VYHjicuZl&X9Gf7UdoB~=N(r~5(S
zgWLR-IJK<-r?U3r$AWeYM|NVrSvT6_y5VZq1?}R4cpTaazWa?R=D6t1iegl7T9l++
zA{^LFh&k(q>Pz!s{B;WY+JDkli*CAHx|Uwuw*9RvgLq)miuAxnDFh06`iHu*<8`=?=d
zwK+CabAD)97_v-~vF>*c(o;)u`BE*62b!_N;Q-QtIx#HWgF(wfxbm)t>-V~0aQPry
zC0oJ1+KU|TDqP4ciaaN*`P#h-T+zZj_xp$muC9SbL}er)w(EPX&l-OvCKKDELWwLC|?IwDxLp{A40F
zG8bvBa4IbpT1bVTnrOn;cO=eb4QthmAu(|&a=r&+<+B9*(91@tRSANXYSC8P44pFv
z&=J>#q*I5`op~4m*A8QRNiR$ub>m9gK@^C#V3^}$)ApC6NiZLuW~L&~WgBj(uYuWj
z23MY_p-+Mz1s2Cit8W{n+*(iUn!~i@&L8rYnue#*=1>z^38~U>r1Gc0Og0Z%-^!4e
z$zd&b_D<~w@jS&nV2^Mkp30tF!5K7dC{CrK)}<
zem##+*X$xcDsD0B_Crp8e?jjbj`&@4CB^j}E~`DIM$3!fkzTai=z)c?JA)@XqtV!b
z6-S=({Q5nj*Igq`^PKE=J26n5N5-$g3~SyT9lam2);TCPbe*V(KY2^Bt|nda;f+4&
zqk5C4I#qHpaz_O%|FA9%(b1c(~-|sxo
zY3k0Fe{Xnr+@A9fpHRE~E~fu1II-r8)HiNre(X#_77UQPim^PipB0%?A1S829jchq
z>$xJQLy;olgbADcO;PSY2Mg!zQaf~(s?OK=ZgCIqcTZ__%>iRA7mAv^!{n7Gg+boL
zF7)BpCU4Y!dElkxPTdPxlQLfN)m==>pNL_aEd4;3&j_#Wns))R&Mwgn-ytNuj+0s??Z+8@%j~B_-y3O%=8`izF
z!>;}{n({ZcZ}eorCLf9G`4axg7ybD@9GK{dz293#g}i3vIyKhC=Okg(8`;?r+Y9{HNco3<#+_qA@$
zElfV1$3tq&T2ETa6OGYC|7c6<)Ov;et@nyc#VZx9q)s_aYP3D~G@<8EQ$Cu`!D{>t
znshqHFRkm03c63{QO`-=Oe&p2I=%`ky$mgl;_1@>u3PvLQ|Ce7pRN*PeZ@uhr<{0lmwWRqX!7|K-~2W(=j~)}#q_|g
zhYlv6J}4RvT~OG5vR2%7%U5(7YfRfK0|{?D2QRr}jd*d6@9Edsns3e7H!sNQ^P1JO
z+(}gTX3$uFX8j99+ccPGAA|VxFMv90U$%RB;IiITdd3{czWW3Vg%x&gmuaDW0>{g1
zs5BnWzfh^g4N>F2H6e-tuMR2PVjLBE9V!*GO{K53{|J_@Tg(Xu$%p?qPgL10wES%N
zIsGM5uQ)S)^LwcW@gX%bfKkJOac&nvhoix0P7h?peP7yb_26=poCCw`*|7aFYZ7kL
zRP7SY`W+!{jMTy`Q*hqCJw}!dikH3~iXWw$74M(>Dl~m$=0o#Ns7DBn*shWu)MJ?R
zyUecIJ6K+Q!mdva)MmTNnc9=2dwy6FM9A6@uKo$ZN;3q#OMzUu;7g&d2T}5TDiU8Z
zYTzT9&a*^);sw@^I>4)}#rRr`VCTVBOgd1h=uqjX*xuh+@T5;yX;=jaSq?w<0*M!t9BF9*|fMi`N1
z;auw*PXB44sC^2=yTXUY*WR%q=r#QwNDNBi?dBKczVCkqm)Ontx0^=z{a!R#qszlS
z35qLkFDMS~@>J|Wo)N3bJ0oL^R(`
zPgi>&KE$b0@af}PVNX|phb{YjyWj0oh+XdgxjcT(~kdDQzE^M>5zy3rNhN*%;W
z&DGLpC^$c;BlRfp`KG7BNO~A_hh!-(9x>!tSbsJypN(CsowV9v#`TesH~sn$%Y`qA
zKH_rDJ=f1%-bLSFwEE
zaUA+zVVKojEI&LWCfo_{?eDlG`|Oz0!H^VA@`ETYq(yV&R5S$7)d<>>Ez+X
z%?wxm*w~ZY;t`I^Zee@GoK}r?Q`3DeMmq*FsKJQR+8o6nquUD6I84z(dKo9Vbz^Yb
z$vp7eNWzdaJU6?>9(QYs+-&K*!9{-+i}Yv?1;_BdRSfC*k?6Gz
z<9kW~U7LDQRqDdiEiY+!{E)<_H&}P}9PJz>&bf33WyAYO@1h=FT@w`-EG!iLP0|z{
z^Bb|rsUOFqX7S2oCpmAW9wh!IOCoL1van~3mK)c*dxJb*!`p_Fkru@*wOD38ishkg
z4AHHl2-OTDYgYiX*Lm{2+?mZ??Z|KOfW=wY7<5vez5bhcabPk%D!OqaTmz?mVTz`e
zHj4YIg^HKWn(^ws)Z1)YMCP&s{MY>=&5iEhpZEm-C5|k(<4(q2U&a*#6OtOin6WWL
zw2z~9OB`)F#4=$*6m9cDdGf~}=cgXr`tpX&DKD@&cb~NyR~f$J6fGXD#rw!O3@kg*
zrI9i-n|LYe#ycz2a%vTuX-D`G1tGsyl6dPlCoHc>-_t#IB|Im)^&4WEc@XXFPv`Vd
z_MeKPzr5~7y+5$zzYlc19LuDI%jGW-IAOX{$_!SL-A^~U)hyC(!WKZ8fjHD>OA!01pr`Xsq<
z`-&HX
zBhEiTfA?)Nhg={mcQ0)h&u5Xc#E|M6W0vtz;g@<((I%=u(Pgg*bN3HnY~(^hrW`4|{~*65vDi4>x{9+OtpM4XvYY5Z>$@+kLjMclA_0jqQQyc};#vJ=FwHAI0F0
zDg=L%Sw4#<;;6fkv>j*gpL<=t+Yf07e94neZaf^|LzA3fem0Jho}4&7lqPWML=rv+
zldw!rpz3)X2R=ul`!twyCEjQ!xMH^MC5=5Fa6s|`&#F%2sj-33u@l%4+L_YV$`lDN
zMVm%(is&i2bTI70j6pNGac2jnn&$lSy2Z;mj~VOr3Z0McXuk5p${>vTKhadKiD$&{
zBs7mEGpS=T8T}I3{wj{;_ahmv9V~r|-ef;@VSl+T?kd(?D6`=6#gnWXwwgi%7(SpK
zXU%^pyuzIn>t^OERyi8eyVqc;n_Eb?#s_F_b&>SuR!lqcjMa8>&b;Em;iiF1G>u?e
zYAl_~6NosNEIp7ZjPXfk^PxmWJc%P>OeBj}1@YC$i}P~s$=?2g6!u;el>Mn`d%
zdfKjGBe-&@1+^DS6hqtEDqb8bSGcRR#%9E5W`#+;?}_6qXlud1?e{rrWlNWfF6`~&
zP2j#@s-{F?{PY94+mo38A_c>-sazeO!iYDCEHjTIAUT40c7fRFd(yeZ8#1z=ae12+
z>#{FWbLs%Kixv{SVK7c{#)PiVRlIh3uW*f0!fbkHdXApJro$W1-+qRG2iM7X|Bx0A
z_AFcZ7X1)ksmqk-YHkc+D-ux7P9`WQmDP>X=;D{cq?AOGmc%iAaRd`T2FSVpJ+Zz{
zTpINh6^q;K4>-@?wA~z>Fo(7k{rK9T&%riHiqkzJ6_(Sqxq77+mj=!tzReCkH#V2g
zz*1^OAM?@0k>u|0sh<{rzIFr`r^m5OFNt--Q~CKJjn*x
zy6tC^^F>yjuwqQ#=RA7-hQ)=RG>QzuX>^qI>B>6ekW9gaG(uz2>9seVnq#T_{+>u=
zLM(IohqJh~KgG}7@yK-Ga@6-)WcO`J
zpRXgiT)iAI>^R%UTQEe6PctDE9bsYdbRRJ+sIAg>~?$|Xw56hjTF5&&gqFOux&dE!&xnf
zsV`B~X@)3z_tvDt*B&g@pU%LO+fmh(-2HsHqezXyJ4+`*S9vfXGmysLBk6TH9;>G*
z%;=VZk8u`FS7q@~FOz4j(^zMf$eZ&q?2!9U6ICA?oL%JkwMB2{Jw|Q1jQ7t&yp#F}
z51S!$-`@mBn_Pw2y%fbIPw5HkJCJGm^J&v(KU(iD;`+e~>krS-ec~*!dT+jMkoD9w
zhSKwibe@yO_w$*o?vTyVmf6hQo5{bvY1~?r$gSFFF1HO~SC*H|rIS0)hUd5}v%+Bb
zMQ(K2$L{L6L}(A-wRt1jw@y;1H2qmH8&?Q1m@Rdc}3TU)s=p
z@xH{m8pzIlR-)BB4_n4__vrZ68I7X^_HHX`<`(ehE
zbC&$nc#6-O*94vM}?_ox}@_=H5<(dA4&N7QDz|Iu!t?y_v@3vSCDIMCDJ7qy`>+eCOV7Y
zq*Maj@yYsL~!&!-q6AxJH!PDcb6;;=$z6loqvQPn%LjUyXc)R+pv>
zNEpVjFH5EW_87zEvtMw|mGLx_wf2Km7TZ%k62IpY8CySL
z9q^Hb`?HvSGnM(B;#oW-0^eLeT>HM|!HAa}YHrPntSj^$aFpxOOE_RZl=bCJWNt&Q
zLforVG;?Xom==P;693;JJvVwvvQDWyLg(u%#@&9;xIckJsYX+5orsHTy5zBPX#L+O
z*p){~lRVT-a(N|xzj#b4b5DJc9>H+BKKDh_$yL5zw#+lWhlcef8jn3d`u_Q{{}13v
zK_hlYCMvdFQK9F6uKb!eg>?yADGV@U?juW=Ytn;y5)vjE;+aux{l-)RX7@P_km+j0@Zxxf`J~
zi(Nf?QxdF2Qel*0l+Z=xWnYZW&0(MGUd~DFK<=QsoK1W|zlpBgI^m1&+HlIscj>~m;7ND~Z6WW38QW|nwh}Bg
z69I2zzKb_0s$m>%{{j7|R0jOW#`JU^ul9YGv*;JX*MH&HssiFXa=CXP6YP?Bza*Mz
za_85){f>rl4){hqAac-E_K4%ej9$jZ^TWtem=M=8S5cLsMW%Ca9%#>Iqt700%)Usn
z)PfifvL*SqD_hL{*d7$Yl=}(f|4wIA(ntE36!6>q3vsW%(&q0Myq*>i@*!bqq
zpU$P_y$sfMOXRR366-2IPAzuB;hZhmm+#7*^CHojd$}`WHa^nxt)HPqSM4H2{?wMl
zzZgy0&efQU({##}{*S|t*z(5_v|W
z`dXGXmzfn0TJdsoi9)%p0nxopnd`GqYH<%UFz*WUtF6hbv*%m-J2oB*;$&P5UA$5V
z@0mlrQ31nOeB+>cF|JA_OrBmWJ+a?7@wI^Hu^-VePNT>AI1W#jJMkwEa!noiu+oNe
z2e0AL@g(kNms2@(IE^-%@L*kmVoYH(mUxV0j?yZeV^3k~a-9};9#JguTw8rFI_wMO
z!nqGrbx)`5>|At;J`+?>NcG?nc4wDxG_jbhR)qxn7qB%lhbt3P@thjV>!Kj;41UkL
zNpfZ!^nfnL7F_#&n0BSo=RMw(#_bG9SzN7{@v=QThKy&+kWCy2JV%$qmJ~{Cut}6N
zXNLIlYh?tldMEPvawhg0^El}ImC8lMTv}L4zHKR;CzPN$tPq>?1^gV9!}hIm_vsje
z*?~ZUj=N(b^*vrv_h|X_5>KA(W5Jj?939<<><}$x*r@Vzd3S;wrZaQ(F4CPYkTFzZ
zl0LR{>?FC%1p&B>iN;0t8^7Fa2JI}M$)-Y{`<7s`v5exCWej~;!lQA8G#M?g|4BAM
zCz6RNjG|4IKYJzC*L;F4b3Lv2-Q@x@s0+vA)6nVMjdzPw7-O!-H?09QYP4
z^9t?Dt;xfIPrKjqeseI*jpJCmD2-`da=Eeb3+@KRyfG@{(E9Hj(EN@=Z3&M@7t*UB
zpW@0a9-U6&!lOv;uJI%OlM7b;o-=&YZJA4GMnKeN_Sj9}LQMy<-G3=guQQ?S<#2Si
zuaG*dQ-tiiPK?bX?Bt%->YW$QcZW&8Pdt}0GFY-Kk4v+@(c7+svU%URJ?96zAAV=o
zkWzHI7V_gjKF0@T(QaQNS0_Z!D#(Yw^>6Udf66_bTg=lw%dSzu
z4sA=|sIhGK-oT;>lE)io$?I{?aOvxU^$%Z?wnx&)GKufgvT;3EAo=+sX7?#$#Q7ic
z-*O^5{NVJuQa=9u#>TolhHc1X>4F6Q?r9<#HiD~9B&^&{k5`X%=K9ulzo@~~Y`VxtAZs>6p<>NIlxQ)^pV3ETjJ3V!*^_>^tQmeGY!K
z*bqhd=VbQQ=3sT@3!kr+pk4lh<
z$gj6J#Rn3+A(pzQY3$wkiC^!(VYj7>m_t7~o>oc!Q&kx5uB4GuIiVv;(eM71E$2S6
zXjKYk2@;R_?#HJX7b?y@qpFuBX_;qfK5;#-2El6ER;;emKzUhj66VceY`}g@d@fUF
zZ_NNp2hOkapjL8M8<)n@VqPXI)AO00T*R5dKPW1%kpH)eaZ{>!onMJXSUH;;N~pf`
zg*}gRsP3JN&AdpmdPtr*{0$26gjOy$Xx`&A^=DV&-h2dkgH5n(Fd(r7!xB)lrLE
zr5)IRZz2OCwn_}(JeC)&IQiX{VUn8)-5x~H;y9|lr}MFCKF55D(24y)^w288Dr+RC
z{|nbqzetR(;*MQ86S9lZK3qWm>zV8t9FNhN5UFW?&-@Mc?CE`XAsFA;zJf)5*>pDL7tEGc}HG7AZ%Y1?&x_RXhIUt=aB3Alp0{D5xjkNsdI1Ikc
zHOq5!?zDmGGq7iSE9Uo-`IP5JV!mfJeb=ACao{bI44z?K;DX^@f9y?S2pyNk&_;Qv
zEi0l$%W}F8sb<@YT4pT$&G)&#rH-nWH;t>g^X-S!N*6Ib@DuhWskCv4CbOGAW?Ni%
zB4@rf_BW-^OnP4wGE->c2;Ss1p}K!Nrp_AAv)ax4IAe}UH!E(W+S25ZJG-ibs2lu&
zhR&I6ep$foS0!w3S%LNE8ot-p;jrY7^ilrCBdeAk8r3qt<_9io3wicFm#vm595IYy
z^jKdGk9&io)Iq&5xQ>_J2|Ok(LG8CG7soZ?U+-?bZ#08rd-f1lYFeVKdD(=Tenq3Sj9Q&4_MWb#>)1aiCe;&V@ke5Qb=>+^#lA*AXmL~o#^EI5Q{AqL@Ymq>8N?!xYviuHaZMy-yhYW1%&4w;fB5R#MIeP
zIQg~Y=zTD_9?9edDHQqTV(eDPJ9D5>VO{%}KId>Ne0qP__SsEZWTJZS1J8d2(XpM>{&balW7j*_4mLwAaRVz}Ky$rTglz1>
zPS2_Ay0Z(rQi(4(-e=1J2c8e`RJxMn{|uiCx7a3eu3H~g;Wupr
z_trJx=Jr11oSw(AmWO3#>s5(;+F&>AHJ9Y9cCUlvO-H99l=J8^r2N
z*Cck2%jMtDBIz;ziQ}bOP6qrX?U9nuJE<%tA5|9jEtSL^c@BmytmWp`pLi7)l2Y`M
zKPQt|85+i2$-}D$*vmYud$hfGfyb-26QVSU0Mib5TlZvN`#F@#S@S=sx7yy%hDIi@
zF)a1r)Wawe4AWTBJD-Nk5=vC6*mM0irMv$TK22E|{8JX*vC3kFr;?a|>95RN`bE*J
za?YoJqxr=gTBaoMN1nYcPu>wQ#|{gLvrP&#lisb39C!%7&a`C2D^pS`me4jp>Vyy6
zU~ku_?9OpP{d53IzvaHzH<7PoedqA$FHEq?q&EqaDLrLrqSe25{oOQVrwOu4!@bvUP-7J
zs)&PaRmJH^s^W=-iqI=p61qk8OdeN5uIhJkM}FqGMh5*3$57@Z^_9MFXc6#;gqW)|
zsyxhc_j#Pr=p+3d-K6((CT9QbXZW=%M7(~;sB9P%_wru`LJxE
z6Bj!?WbyCIeEz-{-6b=)v$QMWvHh7~wg~0u
z_mz#6KhW$`i(zyF{j-(Dx4o*Ow5ytEQ==*jb5%s+uSz1PgS`F^Rs8-Y=b|%tl)I-$
zEmZ`~W_YpnvjZ&-N)KOa>HCuYo#v$zx%Q|%UuBl>rPZr>+5ap~`IdZp{ep&*?kpG`
zBE7f?Vn_&^7FITYf&~MyVD~YvED&ksmHBoJ&CVr1r6CrgfqFa)ZD0=#bKEEs3
z5>U)KJ-Kt$BvD`$MwqsT#GYUBJ3#6QP0i`zu#wcQFmgp}X4Z@)V!#$|%50|+<$Lse
zCUu(QJUJ8>PIT84W(~<`H
z-pgF277v*x{U9Udvp+U38V$);ZW5naZU3F8*M4FDv4O>?h`2#&;`0P`v1qrtu$6yD
zV`Eiec0)f&yUx>%p5ChUz=Mami_G1s$>Cq_Ss`TP~tsaf({JaLo`3SeuQGy5JqX2z0h_#Qq&
zdzX2bo$5{M-ytM@Tfv8ZXIRkDQhuZ01vh6%{r%DqrjW=_$s0W%P>iW=74D1baX+Ih
zmi$u{D%R>Ea+ZcT)>cD!s;P@S4OLOrLrHY4sKvMD2V0JOA@Ftvqu0b>Ugt}c>^lof
zAEG#Th2;zOaYJUq&-D6_6YZfWb|Vd^&GDUnSNa+38QZ~={lCL`YL`M+gM6kmE91Lu
z4V!EmLjGGb5Ru6
z-gtB6$15)Pvu5i>spD?9gD9tol2_}<@nKU?v)@Hk%q3dydBEX5PBbp@!S-4-zf>|9
z((?;XzyDycX&saHD2ZM2z59M&UCheX5FUdxg|4lJ(Cw=(hNq~Au4DeOy3a43S(FjB
zFCX2%DNI&G$i2{$yyf<=`7ZU>&DoQ@k&Z^-^1dgxCe7vJp~GA>y2iw7kBODq)96E6M+LF2e>iecSxi}@CT=X%5VLk_iaz%>#q%r;p*~n$tbVN`Hr#FC
zZ~q!x$CQ$s@rm*l$<#}2opa?o{`lKsf9EzGub$=3fz_0(8P5C~Q%+A`hLz+TtfX$p
z_{DQlr1pQ<+7LEK4$ICem(o!sY};4O{*Dd2x-0LoeCKBwYl=2?nqqXdrtsI)6c-1o
zi@_&U#L?WpH0@lCT3#{geRKIL&z{GZV7i@oi&j(V<@UIV?&(vMsV|kB-$0V3cTr=~
zdeV-VQE6_)Y`2%JEb^d>Q3R)rQn?hLkFn`@R&=c85K6-Lk*e6!QA0Eh(iATaYl+MW
zT4G@jO<~nlUHFev5yzYSmE2(!0lSMZle}Y_uJJfZjw4akl@Y6?hb;aY5lKggJu{C^
zNxi68IFZ~TJJ3qF$o}`%BzrnCEYOF=?$N{?%iy5oEn2ksiF(j){%uwkw`HxnRIMRm
zH)@IWaxGDJRZDCft0@LFRu`%&D#C0?z5K3J1^N}=IO&i@NV7O}=K0I#`-UJnOXg-@
z!TrWQu9Quu)2VLkIWmig)(27RAhV@DJ(7A^XZl{3oXE@%=;mb8uWb>2wUu<3`xnDORd!3%eEC;zq2ND4U}xmR70>y?4su&7?nEy7^P;W53cqAp@P?(Ww6N
z;e^zaen^n}hV(%U8M%Yg6DCp?-=C(p7IUQLB+s|pWR&W2ieF3J%7PF)a}!Y>@QDKh
zN(l_BVRy8ysBd|FF*S!oNkU~OToqAk8I(iF|3)kOX(WzlrfZ$6GGM=9tt
zcMH?#5GVQFD_-P}a^Oatr_*mYJE0B)1ka49A7zh<>pZi(u)gD!$Lv
z{*EM^@xeYcnya5OXy^HrSEh1?9a_&4Iomw(Q5OfsYl+T9+T!$69Wi*Pjwqg~Ee1}~
z6l+$fiO$waqGjV+dTuIX;G8@{ijz1kbZ
z(LTJSZYi?eBZiK0CS_#+wUQf2n3Y3RvE1!DR&ye|fm^3kMY4~EINw5BtiPrsqFU&R
zs&_h~%O-7cslTT9*Fx5RS$qFv*RWsq$>cM+WXPGbkKDK7l%(H4SLz!2T*pWGD4IRz
z(d%j-T6!*^!Qwa`dvCC6#xv>^Z>by@!rVqlD82i{K*KVORci6}_dGB0W9SylwyCUU