spsynth.f

Go to the documentation of this file.

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)
      REAL :: TINYREAL=tiny(1.0)
 
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(abs(clat).LT.tinyreal) 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