spsynth.f

Go to the documentation of this file.

C> @file
C>
C> Synthesize fourier from spectral
C> @author IREDELL @date 92-10-31
 
C> SYNTHESIZES FOURIER COEFFICIENTS FROM SPECTRAL COEFFICIENTS
C> FOR A LATITUDE PAIR (NORTHERN AND SOUTHERN HEMISPHERES).
C> VECTOR COMPONENTS ARE DIVIDED BY COSINE OF LATITUDE.
C>
C> PROGRAM HISTORY LOG:
C> -  91-10-31  MARK IREDELL
C> - 1998-12-18  MARK IREDELL  INCLUDE SCALAR AND GRADIENT OPTION
C>
C> @param I        - INTEGER SPECTRAL DOMAIN SHAPE
C>                (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL)
C> @param M        - INTEGER SPECTRAL TRUNCATION
C> @param IM       - INTEGER EVEN NUMBER OF FOURIER COEFFICIENTS
C> @param IX       - INTEGER DIMENSION OF FOURIER COEFFICIENTS (IX>=IM+2)
C> @param NC       - INTEGER DIMENSION OF SPECTRAL COEFFICIENTS
C>                (NC>=(M+1)*((I+1)*M+2))
C> @param NCTOP    - INTEGER DIMENSION OF SPECTRAL COEFFICIENTS OVER TOP
C>                (NCTOP>=2*(M+1))
C> @param KM       - INTEGER NUMBER OF FIELDS
C> @param CLAT     - REAL COSINE OF LATITUDE
C> @param PLN      - REAL ((M+1)*((I+1)*M+2)/2) LEGENDRE POLYNOMIAL
C> @param PLNTOP   - REAL (M+1) LEGENDRE POLYNOMIAL OVER TOP
C> @param SPC      - REAL (NC,KM) SPECTRAL COEFFICIENTS
C> @param SPCTOP   - REAL (NCTOP,KM) SPECTRAL COEFFICIENTS OVER TOP
C> @param MP       - INTEGER (KM) IDENTIFIERS (0 FOR SCALAR, 1 FOR VECTOR,
C>                OR 10 FOR SCALAR AND GRADIENT)
C>
C> @param F        - REAL (IX,2,KM) FOURIER COEFFICIENTS FOR LATITUDE PAIR
      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 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
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 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
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 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
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
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      END