spanaly.f

Go to the documentation of this file.

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