)
@@ -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 00000000..4085532b
Binary files /dev/null and b/tests/data/sptrung.gi.in differ
diff --git a/tests/data/sptrungv.ll.in b/tests/data/sptrungv.ll.in
new file mode 100644
index 00000000..4edf2f77
Binary files /dev/null and b/tests/data/sptrungv.ll.in differ
diff --git a/tests/data/sptrungv.uv.in b/tests/data/sptrungv.uv.in
new file mode 100644
index 00000000..f5604b9c
Binary files /dev/null and b/tests/data/sptrungv.uv.in differ
diff --git a/tests/data/sptrungv.uv.out b/tests/data/sptrungv.uv.out
new file mode 100644
index 00000000..475ba7a8
Binary files /dev/null and b/tests/data/sptrungv.uv.out differ
diff --git a/tests/input_data_mod_grib1.F90 b/tests/input_data_mod_grib1.F90
index 1499f51e..d9768c26 100644
--- a/tests/input_data_mod_grib1.F90
+++ b/tests/input_data_mod_grib1.F90
@@ -1,11 +1,3 @@
-! This is test code from the NCEPLIBS-ip project.
-!
-! This is a helper module for tests which load some GRIB1 input data
-! to be interpolated.
-!
-! Kyle Gerheiser June, 2021
-
-module input_data_mod_grib1
implicit none
!------------------------------------------------------------------------
@@ -143,5 +135,3 @@ subroutine read_vector_input_data()
return
end subroutine read_vector_input_data
-
-end module input_data_mod_grib1
diff --git a/tests/input_data_mod_grib1_4.F90 b/tests/input_data_mod_grib1_4.F90
new file mode 100644
index 00000000..07e81947
--- /dev/null
+++ b/tests/input_data_mod_grib1_4.F90
@@ -0,0 +1,10 @@
+! This is test code from the NCEPLIBS-ip project.
+!
+! This is a helper module for tests which load some GRIB1 input data
+! to be interpolated.
+!
+! Kyle Gerheiser June, 2021
+
+module input_data_mod_grib1_4
+#include "input_data_mod_grib1.F90"
+end module input_data_mod_grib1_4
diff --git a/tests/input_data_mod_grib1_8.F90 b/tests/input_data_mod_grib1_8.F90
new file mode 100644
index 00000000..e64c30a2
--- /dev/null
+++ b/tests/input_data_mod_grib1_8.F90
@@ -0,0 +1,10 @@
+! This is test code from the NCEPLIBS-ip project.
+!
+! This is a helper module for tests which load some GRIB1 input data
+! to be interpolated.
+!
+! Kyle Gerheiser June, 2021
+
+module input_data_mod_grib1_8
+#include "input_data_mod_grib1.F90"
+end module input_data_mod_grib1_8
diff --git a/tests/input_data_mod_grib1_d.F90 b/tests/input_data_mod_grib1_d.F90
new file mode 100644
index 00000000..5b3841c6
--- /dev/null
+++ b/tests/input_data_mod_grib1_d.F90
@@ -0,0 +1,10 @@
+! This is test code from the NCEPLIBS-ip project.
+!
+! This is a helper module for tests which load some GRIB1 input data
+! to be interpolated.
+!
+! Kyle Gerheiser June, 2021
+
+module input_data_mod_grib1_d
+#include "input_data_mod_grib1.F90"
+end module input_data_mod_grib1_d
diff --git a/tests/input_data_mod_grib2.F90 b/tests/input_data_mod_grib2.F90
index 2b145cac..7238a194 100644
--- a/tests/input_data_mod_grib2.F90
+++ b/tests/input_data_mod_grib2.F90
@@ -1,11 +1,3 @@
-! This is test code from the NCEPLIBS-ip project.
-!
-! This is a helper module for tests which load some GRIB2 input data
-! to be interpolated.
-!
-! Kyle Gerheiser June, 2021
-
-module input_data_mod_grib2
implicit none
!------------------------------------------------------------------------
@@ -140,5 +132,3 @@ subroutine read_vector_input_data()
return
end subroutine read_vector_input_data
-
-end module input_data_mod_grib2
diff --git a/tests/input_data_mod_grib2_4.F90 b/tests/input_data_mod_grib2_4.F90
new file mode 100644
index 00000000..2fbb7428
--- /dev/null
+++ b/tests/input_data_mod_grib2_4.F90
@@ -0,0 +1,10 @@
+! This is test code from the NCEPLIBS-ip project.
+!
+! This is a helper module for tests which load some GRIB2 input data
+! to be interpolated.
+!
+! Kyle Gerheiser June, 2021
+
+module input_data_mod_grib2_4
+#include "input_data_mod_grib2.F90"
+end module input_data_mod_grib2_4
diff --git a/tests/input_data_mod_grib2_8.F90 b/tests/input_data_mod_grib2_8.F90
new file mode 100644
index 00000000..c252217f
--- /dev/null
+++ b/tests/input_data_mod_grib2_8.F90
@@ -0,0 +1,10 @@
+! This is test code from the NCEPLIBS-ip project.
+!
+! This is a helper module for tests which load some GRIB2 input data
+! to be interpolated.
+!
+! Kyle Gerheiser June, 2021
+
+module input_data_mod_grib2_8
+#include "input_data_mod_grib2.F90"
+end module input_data_mod_grib2_8
diff --git a/tests/input_data_mod_grib2_d.F90 b/tests/input_data_mod_grib2_d.F90
new file mode 100644
index 00000000..fc752e29
--- /dev/null
+++ b/tests/input_data_mod_grib2_d.F90
@@ -0,0 +1,10 @@
+! This is test code from the NCEPLIBS-ip project.
+!
+! This is a helper module for tests which load some GRIB2 input data
+! to be interpolated.
+!
+! Kyle Gerheiser June, 2021
+
+module input_data_mod_grib2_d
+#include "input_data_mod_grib2.F90"
+end module input_data_mod_grib2_d
diff --git a/tests/interp_mod_grib1.F90 b/tests/interp_mod_grib1.F90
index 6ea320d1..a2dd7c29 100644
--- a/tests/interp_mod_grib1.F90
+++ b/tests/interp_mod_grib1.F90
@@ -1,8 +1,3 @@
-! This is a test for the NCEPLBS-ip library.
-!
-! Kyle Gerheiser June, 2021
-
-module interp_mod_grib1
use ip_mod
implicit none
@@ -40,10 +35,14 @@ subroutine interp(grid, interp_opt)
! The interpolated data is compared against a baseline binary
! file. Any differences are written to standard output.
!-------------------------------------------------------------------------
- use input_data_mod_grib1, only : input_data, &
- input_kgds, &
- input_bitmap, &
- i_input, j_input
+#if(LSIZE==4)
+ use input_data_mod_grib1_4, &
+#elif(LSIZE==D)
+ use input_data_mod_grib1_d, &
+#elif(LSIZE==8)
+ use input_data_mod_grib1_8, &
+#endif
+ only: input_data, input_kgds, input_bitmap, i_input, j_input
implicit none
@@ -315,9 +314,14 @@ subroutine interp_vector(grid, interp_opt)
! Differences are printed to standard output.
!-------------------------------------------------------------------------
- use input_data_mod_grib1, only : input_u_data, input_v_data, &
- vector_input_kgds, &
- input_bitmap, &
+#if(LSIZE==4)
+ use input_data_mod_grib1_4, &
+#elif(LSIZE==D)
+ use input_data_mod_grib1_d, &
+#elif(LSIZE==8)
+ use input_data_mod_grib1_8, &
+#endif
+ only: input_u_data, input_v_data, vector_input_kgds, input_bitmap, &
i_input, j_input
implicit none
@@ -603,5 +607,3 @@ subroutine interp_vector(grid, interp_opt)
stop 7
end subroutine interp_vector
-
-end module interp_mod_grib1
diff --git a/tests/interp_mod_grib1_4.F90 b/tests/interp_mod_grib1_4.F90
new file mode 100644
index 00000000..b67ba812
--- /dev/null
+++ b/tests/interp_mod_grib1_4.F90
@@ -0,0 +1,7 @@
+! This is a test for the NCEPLBS-ip library.
+!
+! Kyle Gerheiser June, 2021
+
+module interp_mod_grib1_4
+#include "interp_mod_grib1.F90"
+end module interp_mod_grib1_4
diff --git a/tests/interp_mod_grib1_8.F90 b/tests/interp_mod_grib1_8.F90
new file mode 100644
index 00000000..7ae559db
--- /dev/null
+++ b/tests/interp_mod_grib1_8.F90
@@ -0,0 +1,7 @@
+! This is a test for the NCEPLBS-ip library.
+!
+! Kyle Gerheiser June, 2021
+
+module interp_mod_grib1_8
+#include "interp_mod_grib1.F90"
+end module interp_mod_grib1_8
diff --git a/tests/interp_mod_grib1_d.F90 b/tests/interp_mod_grib1_d.F90
new file mode 100644
index 00000000..02109bde
--- /dev/null
+++ b/tests/interp_mod_grib1_d.F90
@@ -0,0 +1,7 @@
+! This is a test for the NCEPLBS-ip library.
+!
+! Kyle Gerheiser June, 2021
+
+module interp_mod_grib1_d
+#include "interp_mod_grib1.F90"
+end module interp_mod_grib1_d
diff --git a/tests/interp_mod_grib2.F90 b/tests/interp_mod_grib2.F90
index 4457b5e1..98d63800 100644
--- a/tests/interp_mod_grib2.F90
+++ b/tests/interp_mod_grib2.F90
@@ -2,7 +2,6 @@
!
! Kyle Gerheiser June, 2021
-module interp_mod_grib2
use ip_mod
implicit none
@@ -41,11 +40,14 @@ subroutine interp(grid, interp_opt)
! file. Any differences are written to standard output.
!-------------------------------------------------------------------------
- use input_data_mod_grib2, only : input_data, &
- input_gdtnum, &
- input_gdtlen, &
- input_gdtmpl, &
- input_bitmap, &
+#if(LSIZE==4)
+ use input_data_mod_grib2_4, &
+#elif(LSIZE==D)
+ use input_data_mod_grib2_d, &
+#elif(LSIZE==8)
+ use input_data_mod_grib2_8, &
+#endif
+ only : input_data, input_gdtnum, input_gdtlen, input_gdtmpl, input_bitmap, &
i_input, j_input
implicit none
@@ -395,12 +397,15 @@ subroutine interp_vector(grid, interp_opt)
! Differences are printed to standard output.
!-------------------------------------------------------------------------
- use input_data_mod_grib2, only : input_u_data, input_v_data, &
- vector_input_gdtmpl, &
- input_gdtlen, &
- input_gdtnum, &
- input_bitmap, &
- i_input, j_input
+#if(LSIZE==4)
+ use input_data_mod_grib2_4, &
+#elif(LSIZE==D)
+ use input_data_mod_grib2_d, &
+#elif(LSIZE==8)
+ use input_data_mod_grib2_8, &
+#endif
+ only : input_u_data, input_v_data, vector_input_gdtmpl, input_gdtlen, &
+ input_gdtnum, input_bitmap, i_input, j_input
implicit none
@@ -773,5 +778,3 @@ subroutine interp_vector(grid, interp_opt)
stop 7
end subroutine interp_vector
-
-end module interp_mod_grib2
diff --git a/tests/interp_mod_grib2_4.F90 b/tests/interp_mod_grib2_4.F90
new file mode 100644
index 00000000..c8e23ce5
--- /dev/null
+++ b/tests/interp_mod_grib2_4.F90
@@ -0,0 +1,7 @@
+! This is a test for the NCEPLBS-ip library.
+!
+! Kyle Gerheiser June, 2021
+
+module interp_mod_grib2_4
+#include "interp_mod_grib2.F90"
+end module interp_mod_grib2_4
diff --git a/tests/interp_mod_grib2_8.F90 b/tests/interp_mod_grib2_8.F90
new file mode 100644
index 00000000..fbd63ffc
--- /dev/null
+++ b/tests/interp_mod_grib2_8.F90
@@ -0,0 +1,7 @@
+! This is a test for the NCEPLBS-ip library.
+!
+! Kyle Gerheiser June, 2021
+
+module interp_mod_grib2_8
+#include "interp_mod_grib2.F90"
+end module interp_mod_grib2_8
diff --git a/tests/interp_mod_grib2_d.F90 b/tests/interp_mod_grib2_d.F90
new file mode 100644
index 00000000..bb36b421
--- /dev/null
+++ b/tests/interp_mod_grib2_d.F90
@@ -0,0 +1,7 @@
+! This is a test for the NCEPLBS-ip library.
+!
+! Kyle Gerheiser June, 2021
+
+module interp_mod_grib2_d
+#include "interp_mod_grib2.F90"
+end module interp_mod_grib2_d
diff --git a/tests/test_fft.F90 b/tests/test_fft.F90
new file mode 100644
index 00000000..15b2b11d
--- /dev/null
+++ b/tests/test_fft.F90
@@ -0,0 +1,117 @@
+! Unit tests for FFT and inverse FFT.
+!
+! Kyle Gerheiser
+program test_fft
+ use iso_fortran_env, only: real32, real64
+ implicit none
+
+#ifdef KIND_d
+ real, parameter :: PI = 3.14159265358979
+ integer, parameter :: precision = real64
+ integer, parameter :: imax = 256
+ integer, parameter :: incw = (imax / 2) + 1
+ integer, parameter :: incg = imax
+ integer, parameter :: kmax = 1
+
+ integer, parameter :: IDIR_C2R = 1
+ integer, parameter :: IDIR_R2C = -1
+
+ call test_fft_real_to_complex()
+ print *, "test_fft_real_to_complex - Complete"
+ call test_fft_complex_to_real()
+ print *, "test_fft_complex_to_real - Complete"
+ print *, "SUCCESS"
+
+contains
+
+ ! Test FFT
+ ! Construct a wave with known parameters, sample it, run it through FFT,
+ ! then check if frequency and DC component match the test signal.
+ subroutine test_fft_real_to_complex()
+ real(precision) :: amplitude, freq_hz, t, cosine, dt, sample_rate_hz, dc_component, df, f, magnitude
+ real(real64) :: AFFT(50000+4*IMAX)
+ real(precision), allocatable :: w(:,:), g(:,:)
+ integer :: i
+ complex :: dft
+
+ real :: max_freq=-999.9, max_magnitude
+
+ ! Setup the test wave
+ amplitude = 1.0
+ freq_hz = 12.0
+ sample_rate_hz = 64
+ dc_component = 42.0
+
+ df = sample_rate_hz / imax
+ dt = 1.0 / sample_rate_hz
+
+ allocate(w(2*incw, kmax), g(incg, kmax))
+
+ t = 0.0
+ do i = 1, imax
+ cosine = amplitude * cos(2.0 * pi * freq_hz * t) + dc_component
+ g(i,1) = cosine
+ t = t + dt
+ end do
+
+ ! Initialize spfft by passing 0 to IDIR
+ call spffte(imax, incw, incg, kmax, w, g, 0, afft)
+ ! Calculate FFT
+ call spffte(imax, incw, incg, kmax, w, g, IDIR_R2C, afft)
+
+ max_magnitude = 0.0
+ do i = 2, imax, 2
+ ! Turn real array into complex numbers
+ dft = cmplx(w(i,1), w(i+1,1))
+ magnitude = abs(dft)
+ f = i * df / 2
+ if (magnitude > max_magnitude) then
+ max_freq = f
+ max_magnitude = magnitude
+ end if
+ end do
+
+ ! The frequency bin with the largest amplitude should match the test wave
+ if (abs(max_freq - freq_hz) > 0.05) then
+ error stop "FFT frequency does not match test wave"
+ end if
+
+ ! The first component of the FFT is the DC component of the wave
+ if (abs(w(1,1) - dc_component) > 0.05) then
+ error stop "DC component of FFT does not match test wave"
+ end if
+
+ end subroutine test_fft_real_to_complex
+
+ ! Test inverse FFT.
+ ! Run synthetic test array through FFT and run results through inverse FFT
+ ! to obtain the original array
+ subroutine test_fft_complex_to_real()
+ real(real64) :: AFFT(50000+4*IMAX)
+ real(precision), allocatable :: w(:,:), g(:,:), g_new(:,:)
+ integer :: i
+
+ allocate(w(2*incw, kmax), g(incg, kmax), g_new(incg, kmax))
+
+ ! Setup test array with synthetic data
+ do i = 1, imax
+ g(i,1) = i
+ end do
+
+ ! Initialize spfft by passing 0 to IDIR
+ call spffte(imax, incw, incg, kmax, w, g, 0, afft)
+ ! Calculate FFT
+ call spffte(imax, incw, incg, kmax, w, g, IDIR_R2C, afft)
+ ! Calculate inverse on to get original 'g' back
+ call spffte(imax, incw, incg, kmax, w, g_new, IDIR_C2R, afft)
+
+ do i = 1, imax
+ if (abs(g(i,1) - g_new(i,1)) > 0.05) then
+ error stop "Inverse FFT failed"
+ end if
+ end do
+
+ end subroutine test_fft_complex_to_real
+
+#endif
+end program test_fft
diff --git a/tests/test_ncpus.F90 b/tests/test_ncpus.F90
new file mode 100644
index 00000000..53d798cb
--- /dev/null
+++ b/tests/test_ncpus.F90
@@ -0,0 +1,16 @@
+! This is a test from the NCEPLIBS-sp project.
+!
+! This test tests the ncpus() function.
+!
+! Kyle Gerheiser
+program test_ncpus
+ implicit none
+
+ integer :: n, ncpus
+
+ n = ncpus()
+#ifndef OPENMP
+ if (n .ne. 1) stop 2
+#endif
+
+end program test_ncpus
diff --git a/tests/test_scalar_grib1.F90 b/tests/test_scalar_grib1.F90
index bf70080b..4c131251 100644
--- a/tests/test_scalar_grib1.F90
+++ b/tests/test_scalar_grib1.F90
@@ -2,8 +2,16 @@
!
! Kyle Gerheiser June, 2021
program test_scalar_grib1
- use input_data_mod_grib1
- use interp_mod_grib1
+#if(LSIZE==4)
+ use input_data_mod_grib1_4
+ use interp_mod_grib1_4
+#elif(LSIZE==D)
+ use input_data_mod_grib1_d
+ use interp_mod_grib1_d
+#elif(LSIZE==8)
+ use input_data_mod_grib1_8
+ use interp_mod_grib1_8
+#endif
implicit none
integer :: num_args, len, status
diff --git a/tests/test_scalar_grib2.F90 b/tests/test_scalar_grib2.F90
index 5e5d1be4..d7c7ab63 100644
--- a/tests/test_scalar_grib2.F90
+++ b/tests/test_scalar_grib2.F90
@@ -2,8 +2,16 @@
!
! Kyle Gerheiser June, 2021
program test_scalar_grib2
- use input_data_mod_grib2
- use interp_mod_grib2
+#if(LSIZE==4)
+ use input_data_mod_grib2_4
+ use interp_mod_grib2_4
+#elif(LSIZE==D)
+ use input_data_mod_grib2_d
+ use interp_mod_grib2_d
+#elif(LSIZE==8)
+ use input_data_mod_grib2_8
+ use interp_mod_grib2_8
+#endif
implicit none
integer :: num_args, len, status
diff --git a/tests/test_splaplac.F90 b/tests/test_splaplac.F90
new file mode 100644
index 00000000..b733e330
--- /dev/null
+++ b/tests/test_splaplac.F90
@@ -0,0 +1,47 @@
+! This is a test from the NCEPLIBS-sp project.
+!
+! This test tests the splaplac() subrroutine.
+!
+! Alex Richert, Oct 2023
+PROGRAM TEST_SPLAPLAC
+ IMPLICIT NONE
+
+ INTEGER I, M, J, QSIZE, QD2SIZE
+ REAL, ALLOCATABLE :: ENN1(:), Q(:), QD2(:), QREF(:), REF(:), QD2REF(:)
+ REAL :: TOL=1E-7
+
+ M=2
+
+ DO I=0,1
+ QSIZE=(M+1)*((I+1)*M+2)
+ QD2SIZE=(M+1)*((I+1)*M+2)
+ ALLOCATE(QD2REF(QD2SIZE))
+ IF (I.EQ.0) THEN
+ QD2REF=(/0.0,0.0,-0.25,-0.333,-0.417,-0.5,-0.583,-0.667, &
+ -0.75,-0.833,-0.917,-1.0/)
+ ELSEIF (I.EQ.1) THEN
+ QD2REF=(/0.0,0.0,-0.167,-0.222,-0.278,-0.333,-0.389,-0.444, &
+ -0.5,-0.556,-0.611,-0.667,-0.722,-0.778,-0.833,-0.889,-0.944,-1.0/)
+ ENDIF
+ ALLOCATE(ENN1((M+1)*((I+1)*M+2)/2))
+ ENN1=1.0
+ ALLOCATE(Q(QSIZE))
+ ALLOCATE(QREF(QSIZE))
+ ALLOCATE(QD2(QD2SIZE))
+ DO J=1,QSIZE
+ Q(J) = REAL(J)/REAL(QSIZE)
+ ENDDO
+ QREF=Q
+ CALL SPLAPLAC(I,M,ENN1,Q,QD2,1)
+ IF (.NOT.ALL(ABS(QD2-QD2REF).LT.1E-2)) STOP 1
+ Q=-999.9
+ CALL SPLAPLAC(I,M,ENN1,Q,QD2,-1)
+ IF (.NOT.ALL(ABS(Q(3:)-QREF(3:)).LT.TOL)) STOP 2
+ DEALLOCATE(QD2REF)
+ DEALLOCATE(ENN1)
+ DEALLOCATE(Q)
+ DEALLOCATE(QREF)
+ DEALLOCATE(QD2)
+ ENDDO !DO I
+
+END PROGRAM TEST_SPLAPLAC
diff --git a/tests/test_splat.F90 b/tests/test_splat.F90
new file mode 100644
index 00000000..29685b1c
--- /dev/null
+++ b/tests/test_splat.F90
@@ -0,0 +1,50 @@
+! This is a test from the NCEPLIBS-sp project.
+!
+! This test tests the splat() subrroutine.
+!
+! Kyle Gerheiser
+program test_splat
+ use iso_fortran_env, only: real64
+ implicit none
+
+ integer :: j, jj, jmax, ref_j(5)
+ real :: slat(584), wlat(584), ref_slat(5), ref_wlat(5)
+ real :: tini=1e-5
+
+ jmax = 584 ! t382 grid
+
+ call splat(0, jmax, slat, wlat)
+
+ if (slat(1) /= 1d0) then
+ error stop "slat(1) should equal 1.0"
+ endif
+
+ if(slat(jmax) /= -1d0) then
+ error stop "slat(jmax) should equal -1.0"
+ endif
+
+ if(wlat(1) /= 0d0) then
+ error stop "wlat(1) should equal 0.0"
+ endif
+
+ if(wlat(jmax) /= 0d0) then
+ error stop "wlat(jmax) should equal 0.0"
+ endif
+
+ do j = 2, jmax-1
+ if (slat(j) < slat(j+1)) then
+ error stop "slat should be monotonically decreasing"
+ endif
+ end do
+
+ call splat(256, jmax, slat, wlat)
+ ref_j = (/1, 20, 100, 292, 584/)
+ ref_slat = (/0.999996364, 0.994503140, 0.860138953, 2.68967217E-03, -0.999996364/)
+ ref_wlat = (/1.25922097E-05, 5.63323090E-04, 2.74388562E-03, 5.37929870E-03, 1.25922097E-05/)
+
+ do jj = 1, 5
+ if (abs(ref_slat(jj)-slat(ref_j(jj))) .gt. tini) error stop "slat mismatch for IDRT=256"
+ if (abs(ref_wlat(jj)-wlat(ref_j(jj))) .gt. tini) error stop "wlat mismatch for IDRT=256"
+ enddo
+
+end program test_splat
diff --git a/tests/test_sppad.F90 b/tests/test_sppad.F90
new file mode 100644
index 00000000..f1b69edf
--- /dev/null
+++ b/tests/test_sppad.F90
@@ -0,0 +1,51 @@
+! This is a test from the NCEPLIBS-sp project.
+!
+! This test tests the sppad() subrroutine.
+!
+! Alex Richert, Oct 2023
+PROGRAM TEST_SPPAD
+ IMPLICIT NONE
+
+ INTEGER WHICH, I, IMAX1, IMAX2
+ INTEGER, DIMENSION(6) :: I1=(/0,1,0,0,1,1/), I2=(/0,1,0,1,0,1/)
+ INTEGER, DIMENSION(6) :: M1=(/384,384,1,1,1,1/), M2=(/384,384,2,2,2,2/)
+ REAL, ALLOCATABLE :: Q1(:), Q2(:)
+ REAL :: TINI=TINY(1.0)
+ REAL, DIMENSION(18) :: W4REF, W6REF
+
+ W4REF=(/1.0/6.0,1.0/3.0,0.5,2.0/3.0,0.0,0.0, &
+ 5.0/6.0,1.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0/)
+ W6REF=(/0.1250,0.25,0.375,0.5,0.0,0.0,0.625,0.75,0.875,1.0, &
+ 0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0/)
+
+ DO WHICH=1,6
+ IMAX1=(M1(WHICH)+1)*((I1(WHICH)+1)*M1(WHICH)+2)
+ IMAX2=(M2(WHICH)+1)*((I2(WHICH)+1)*M2(WHICH)+2)
+ IF ((WHICH.LE.2) .AND. (IMAX1.NE.IMAX2)) STOP 1
+ ALLOCATE(Q1(1:IMAX1))
+ ALLOCATE(Q2(1:IMAX2))
+ ! Make all test values positive to distinguish from padding zeros
+ DO I=1,IMAX1
+ Q1(I)=REAL(I)/REAL(IMAX1)
+ ENDDO
+ CALL SPPAD(I1(WHICH),M1(WHICH),Q1,I2(WHICH),M2(WHICH),Q2)
+ ! When I1==I2, the arrays should be unchanged
+ IF (WHICH.EQ.1) THEN
+ IF (.NOT.ALL(ABS(Q1-Q2).LT.TINI)) STOP 2
+ ENDIF
+ IF (WHICH.EQ.2) THEN
+ IF (.NOT.ALL(ABS(Q1-Q2).LT.TINI)) STOP 3
+ ENDIF
+ ! Non-pad values (i.e., non-zeros) should be unchanged
+ IF (.NOT. ALL(ABS(Q1-PACK(Q2,Q2>TINI)).LT.TINI)) STOP 4
+ IF (WHICH.EQ.4) THEN
+ IF (.NOT.ALL(ABS(Q2-W4REF).LT.TINI)) STOP 5
+ ENDIF
+ IF (WHICH.EQ.6) THEN
+ IF (.NOT.ALL(ABS(Q2-W6REF).LT.TINI)) STOP 6
+ ENDIF
+ DEALLOCATE(Q1)
+ DEALLOCATE(Q2)
+ ENDDO ! WHICH=1,6
+
+END PROGRAM TEST_SPPAD
diff --git a/tests/test_sptezv.F90 b/tests/test_sptezv.F90
new file mode 100644
index 00000000..0e9b82be
--- /dev/null
+++ b/tests/test_sptezv.F90
@@ -0,0 +1,79 @@
+! This is a test from the NCEPLIBS-sp project.
+!
+! This test tests the sptez() and sptezv() subrroutines.
+!
+! Kyle Gerheiser
+program test_sptezv
+ use iso_fortran_env, only: real64
+ implicit none
+
+#ifdef KIND_d
+ integer,parameter:: iromb=0,maxwv=7
+ integer,parameter:: idrtg=4,idrte=0,imax=16,jmaxg=8,jmaxe=17
+ real(real64) :: MAX_DIFF = 1d-9
+
+ call test_scalar(iromb,maxwv,idrtg,imax,jmaxg)
+ call test_scalar(iromb,maxwv,idrte,imax,jmaxe)
+ call test_vector(iromb,maxwv,idrtg,imax,jmaxg)
+ call test_vector(iromb,maxwv,idrte,imax,jmaxe)
+
+ call test_scalar(0,126,4,256,128)
+ call test_scalar(0,126,0,256,257)
+ call test_vector(0,126,4,256,128)
+ call test_vector(0,126,0,256,257)
+
+contains
+
+ subroutine test_scalar(iromb,maxwv,idrt,imax,jmax)
+ implicit none
+ integer,intent(in):: iromb,maxwv,idrt,imax,jmax
+ real(real64) :: wave((maxwv+1)*((iromb+1)*maxwv+2)/2*2)
+ real(real64) :: wave2((maxwv+1)*((iromb+1)*maxwv+2)/2*2)
+ real(real64) :: grid(imax,jmax)
+ real(real64) :: avg_diff
+ wave=1d0
+ wave(2:2*maxwv+2:2)=0d0
+ call sptez(iromb,maxwv,idrt,imax,jmax,wave,grid,+1)
+ call sptez(iromb,maxwv,idrt,imax,jmax,wave2,grid,-1)
+ avg_diff = sqrt(sum((wave2-wave)**2)/size(wave))
+
+ print *, "avg_diff = ", avg_diff
+
+ if (avg_diff > MAX_DIFF) then
+ print *, "average difference > MAX_DIFF: ", avg_diff, " > ", MAX_DIFF
+ error stop
+ endif
+
+ end subroutine test_scalar
+
+ subroutine test_vector(iromb,maxwv,idrt,imax,jmax)
+ implicit none
+ integer,intent(in):: iromb,maxwv,idrt,imax,jmax
+ real(real64) :: waved((maxwv+1)*((iromb+1)*maxwv+2)/2*2)
+ real(real64) :: wavez((maxwv+1)*((iromb+1)*maxwv+2)/2*2)
+ real(real64) :: waved2((maxwv+1)*((iromb+1)*maxwv+2)/2*2)
+ real(real64) :: wavez2((maxwv+1)*((iromb+1)*maxwv+2)/2*2)
+ real(real64) :: gridu(imax,jmax)
+ real(real64) :: gridv(imax,jmax)
+ real(real64) :: avg_diff
+ waved=1d0
+ waved(2:2*maxwv+2:2)=0d0
+ waved(1)=0d0
+ wavez=1d0
+ wavez(2:2*maxwv+2:2)=0d0
+ wavez(1)=0d0
+ call sptezv(iromb,maxwv,idrt,imax,jmax,waved,wavez,gridu,gridv,+1)
+ call sptezv(iromb,maxwv,idrt,imax,jmax,waved2,wavez2,gridu,gridv,-1)
+ avg_diff = sqrt((sum((waved2-waved)**2)+sum((wavez2-wavez)**2))/(2*size(waved)))
+
+ print *, "avg_diff = ", avg_diff
+
+ if (avg_diff > MAX_DIFF) then
+ print *, "average difference > MAX_DIFF: ", avg_diff, " > ", MAX_DIFF
+ error stop
+ endif
+
+ end subroutine test_vector
+#endif
+
+end program test_sptezv
diff --git a/tests/test_sptrung.F90 b/tests/test_sptrung.F90
new file mode 100644
index 00000000..8f0c30b8
--- /dev/null
+++ b/tests/test_sptrung.F90
@@ -0,0 +1,41 @@
+! This is a test from the NCEPLIBS-sp project.
+!
+! This test tests the sptrung() subrroutine.
+!
+! Alex Richert, Oct 2023
+program test_sptrung
+ implicit none
+
+ INTEGER :: I
+ INTEGER :: IROMB=0, MAXWV=89
+ INTEGER :: IDRTI=256, IMAXI=360, JMAXI=180
+ INTEGER,parameter :: KM=1
+ INTEGER :: NO=4, IPRIME=181, ISKIPI=1, JSKIPI=360
+ INTEGER,parameter :: MI=64800, MO=4
+ REAL :: RLAT(MO),RLON(MO)
+ REAL :: GI(MI,KM)
+ REAL :: GO(MO,KM)
+ REAL :: GOREF(MO,KM)
+ REAL*4 :: RDGI(MI,KM)
+ REAL :: TINI=4e-3
+
+
+ OPEN (12, file="data/sptrung.gi.in", form='unformatted', recl=MI*KM*4, convert='little_endian')
+ READ (12) RDGI
+ CLOSE (12)
+
+ GI = REAL(RDGI)
+
+ GOREF(:,1) = (/77.3174667,70.4562683,72.8935242,51.0591698/)
+ RLAT = (/45.0,35.0,40.0,35.0/)
+ RLON = (/-100.0,-100.0,-90.0,-120.0/)
+
+ CALL SPTRUNG(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KM,NO, &
+ IPRIME,ISKIPI,JSKIPI,MI,MO,0,0,0,RLAT,RLON, &
+ GI,GO)
+
+ DO I=1,MO
+ IF (ABS(GO(I,KM)-GOREF(I,KM)) .GT. TINI) STOP 1
+ ENDDO
+
+end program test_sptrung
diff --git a/tests/test_sptrungv.F90 b/tests/test_sptrungv.F90
new file mode 100644
index 00000000..fb772369
--- /dev/null
+++ b/tests/test_sptrungv.F90
@@ -0,0 +1,58 @@
+! This is a test from the NCEPLIBS-sp project.
+!
+! This test tests the sptrungv() subrroutine.
+!
+! Alex Richert, Oct 2023
+program test_sptrungv
+ implicit none
+
+ !
+ !
+ INTEGER :: I
+ INTEGER :: IROMB=0, MAXWV=89
+ INTEGER :: IDRTI=0, IMAXI=360, JMAXI=181
+ INTEGER,parameter :: KM=1
+ INTEGER :: NO=26553, IPRIME=1, ISKIPI=1, JSKIPI=-360
+ INTEGER,parameter :: MI=65160, MO=26553
+ REAL :: RLAT(MO),RLON(MO)
+ REAL :: UI(MI,KM),VI(MI,KM)
+ REAL :: UO(MO,KM),VO(MO,KM)
+ REAL :: UOREF(MO,KM),VOREF(MO,KM)
+ REAL*4 :: RDRLAT(MO),RDRLON(MO)
+ REAL*4 :: RDUI(MI,KM),RDVI(MI,KM)
+ REAL*4 :: RDUOREF(MO,KM),RDVOREF(MO,KM)
+ REAL :: X=0.0
+ REAL :: TOL=1e-2
+
+ OPEN (12, file="data/sptrungv.uv.in", access='direct', recl=MI*KM*4, convert='little_endian')
+ READ (12, rec=1) RDUI
+ READ (12, rec=2) RDVI
+ CLOSE (12)
+
+ OPEN (13, file="data/sptrungv.ll.in", access="direct", recl=MO*4, convert='little_endian')
+ READ (13, rec=1) RDRLAT
+ READ (13, rec=2) RDRLON
+ CLOSE (13)
+
+ OPEN (14, file="data/sptrungv.uv.out", access="direct", recl=MO*KM*4, convert='little_endian')
+ READ (14, rec=1) RDUOREF
+ READ (14, rec=2) RDVOREF
+ CLOSE (14)
+
+ UI = REAL(RDUI)
+ VI = REAL(RDVI)
+ RLAT = REAL(RDRLAT)
+ RLON = REAL(RDRLON)
+ UOREF = REAL(RDUOREF)
+ VOREF = REAL(RDVOREF)
+
+ CALL SPTRUNGV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KM,NO, &
+ IPRIME,ISKIPI,JSKIPI,MI,MO,0,0,0,RLAT,RLON, &
+ UI,VI,.TRUE.,UO,VO,.FALSE.,X,X,.FALSE.,X,X)
+
+ DO I=1, MO
+ IF (ABS(UO(I,KM)-RDUOREF(I,KM)) .GT. TOL) STOP 1
+ IF (ABS(VO(I,KM)-RDVOREF(I,KM)) .GT. TOL) STOP 2
+ ENDDO
+
+end program test_sptrungv
diff --git a/tests/test_vector_grib1.F90 b/tests/test_vector_grib1.F90
index f503cbc6..7e1fbbdf 100644
--- a/tests/test_vector_grib1.F90
+++ b/tests/test_vector_grib1.F90
@@ -2,8 +2,16 @@
!
! Kyle Gerheiser June, 2021
program test_vector
- use input_data_mod_grib1
- use interp_mod_grib1
+#if(LSIZE==4)
+ use input_data_mod_grib1_4
+ use interp_mod_grib1_4
+#elif(LSIZE==D)
+ use input_data_mod_grib1_d
+ use interp_mod_grib1_d
+#elif(LSIZE==8)
+ use input_data_mod_grib1_8
+ use interp_mod_grib1_8
+#endif
implicit none
integer :: num_args, len, status
diff --git a/tests/test_vector_grib2.F90 b/tests/test_vector_grib2.F90
index 8ea7f2bf..4d48845a 100644
--- a/tests/test_vector_grib2.F90
+++ b/tests/test_vector_grib2.F90
@@ -2,8 +2,16 @@
!
! Kyle Gerheiser June, 2021
program test_vector_grib2
- use input_data_mod_grib2
- use interp_mod_grib2
+#if(LSIZE==4)
+ use input_data_mod_grib2_4
+ use interp_mod_grib2_4
+#elif(LSIZE==D)
+ use input_data_mod_grib2_d
+ use interp_mod_grib2_d
+#elif(LSIZE==8)
+ use input_data_mod_grib2_8
+ use interp_mod_grib2_8
+#endif
implicit none
integer :: num_args, len, status