*=*=*=*= harmspher.html =*=*=*=*
SUBROUTINE harmspher

SUBROUTINE harmspher


      SUBROUTINE harmspher( fphi,psi )
c
c   ...   F. Hourdin, P. Le Van  ....
c
      IMPLICIT NONE
c
c     Ce prog. calcule les harmoniques spheriques determinees comme vecteurs
c     propres du laplacien discretise du GCM du LMD .
c
c     La grille de travail horizontale est une grille de type C(Arakawa).
c     On a un systeme de coordonnees cylindiques Longitude = fx(X) et
c      Latitude = fy(Y)  .
c
c     Si on cherche des solutions de la forme f(X)*g(Y) ,cela revient a de-
c     velopper le laplacien successivement en longitude et en latitude ,
c     et a chercher les fonctions propres de la matrice RL(resolut. en longit)
c     puis pour chacune de ces  iim valeurs propres eigvrl(i) ,a chercher les
c     fonctions propres des matrices RM ( resolution en latitude) correspon-
c     dant a  eigvrl(i) # 0. , ainsi que celles de la matrice RM0 correspondant
c     a  eigvrl =  0.
c
c     Les fonctions propres des matrices de travail rl,rm,rm0 sont prefixees
c     par  eigf ( f : functions ) .
c     Les valeurs propres  de ces matrices sont prefixees par eigv ( v :values)
c
c     Ces differentes matrices ont ete rendues symetriques et de la , on peut
c     utiliser la routine  jacobi et ensuite eigsrt qui reordonne les va -
c     leurs propres dans l'ordre decroissant( algebriquement) et aussi les
c     fonctions propres correspondantes ,en colonnes dans les tableaux prefi-
c     xes par eigf .
c
c     En sortie de ce s-pg , on a dans rphi et psi , respectivement les harmoni-
c     ques eigfrl(i)/alpha(i) et  eigfrm(j)/beta(j) et eigfrm0(j)/beta(j) .
c
c
c     N.B   ;  .. important ...
c
c     psi est indice comme suit :  psi( j,m,l)   avec  j = 1, jjm +1
c                                                      m = 1, jjm +1
c                                                      l = 1, iim
c     l = 1   correspond a la plus grande valeur propre eigvrl de RL
c     l = iim correspond a la plus petite valeur propre eigvrl de RL
c
c    m = 1 correspond a la plus grande valeur propre eigvrm ou eigvrm0 de RM
c                                                                ou    de RM0
c    m =jjm-1  correspond a la plus petite valeur propre eigvrm         de RM
c    m =jjm+1 correspond a la plus petite valeur propre eigvrm0        de RM0
c
c    Donc ,pour l donne,par exemple a 2,  si eigvrl(2) # 0. , m = 3 ,par exemp.
c    correspond a la valeur propre eigvrm(3) de RM,pour cette valeur eigvrl(2).
c    Psi(j,3,2) ,ou j=1,jjp1 est alors l'harmonique qui correspond a la valeur
c    propre eigvrl(2) de RL et a la valeur propre eigvrm(3) de RM , matrice
c    formulee avec la valeur de eigvrl(2)  .
c

#include "dimensions.h"
#include "paramet.h"
      INTEGER jjm1
      PARAMETER(jjm1=jjm-1)

      REAL alpha(iim),alphas(0:iim),beta(jjp1),betas(jjp1)
      REAL rl(iim,iim),rm(jjm1,jjm1),rm0(jjp1,jjp1)
      REAL eigvrl(iim),eigvrm(jjm1),eigvrm0(jjp1)
      REAL eigfrl(iim,iim),eigfrm(jjm1,jjm1),eigfrm0(jjp1,jjp1)
      REAL psi(jjp1,jjp1,iim) , fphi(iim,iim)
      REAL rx1,ry,rys,pi
      INTEGER i,j,k,l,m,nrot
      EXTERNAL jacobi, eigsrt
c
c
#include "serre.h"
#include "fxyprim.h"
c
      pi=2.*ASIN(1.)
c
c   ......construction de la matrice RL  : voir formulations F.Hourdin ....
c   .......................................................................
c
      DO 1 i=1,iim
      rx1=fxprim(FLOAT(i)-0.25) + fxprim(FLOAT(i)+0.25)
      alpha(i)=SQRT(2./rx1)
1     CONTINUE
      DO 2 i=0,iim
      rx1      = fxprim(FLOAT(i)+0.25) + fxprim(FLOAT(i)+0.75)
      alphas(i)= 0.5*rx1/( fxprim(i+0.5)*fxprim(i+0.5) )
2     CONTINUE
      DO 3 j=1,iim
      DO 3 i=1,iim
      rl(i,j)= 0.
3     CONTINUE
      DO 4 i=1,iim
      rl(i,i)= -alpha(i)*alpha(i)*(alphas(i-1)+alphas(i))
4     CONTINUE
      DO 5 i=1,iim -1
      rl(i,i+1)= alpha(i)*alpha(i+1)*alphas(i)
      rl(i+1,i)= rl(i,i+1)
5     CONTINUE
      rl(1,iim)= alpha(1)*alpha(iim)*alphas(iim)
      rl(iim,1)= rl(1,iim)

c
      CALL jacobi ( rl,iim,iim,eigvrl,eigfrl,nrot )
      CALL eigsrt ( eigvrl,eigfrl,iim,iim )
c
      CALL orthonorm( iim,iim,eigfrl)
c
      DO 6 j = 1 ,iim
      DO 6 i = 1, iim
      fphi(i,j) = eigfrl(i,j) * alpha(i)
6     CONTINUE
c
c
c
c   .... Calcul des coeffic. beta (aux pts scalaires) et betas(aux pts u) ..
c   qui seront utilises pour les matrices RM et RM0 ( resol.en latitude) ...
c
      DO 7 j= 2, jjm
      ry =  COS( fy(FLOAT(j)-0.25) ) * fyprim( FLOAT(j)- 0.25 ) +
     *      COS( fy(FLOAT(j)+0.25) ) * fyprim( FLOAT(j)+ 0.25 )
      rys = COS( fy(FLOAT(j)+0.25) ) * fyprim( FLOAT(j)+ 0.25 ) +
     *      COS( fy(FLOAT(j)+0.75) ) * fyprim( FLOAT(j)+ 0.75 )
      beta (j) = SQRT( 2./ry )
      betas(j) = 0.5*rys/(fyprim(FLOAT(j)+0.5)*fyprim(FLOAT(j)+0.5))
7     CONTINUE
c
      beta(1) =SQRT(2./( COS(fy(FLOAT(1)+0.25))*fyprim(FLOAT(1)+0.25)))
      rys = COS( fy(FLOAT(1)+0.25) ) * fyprim( FLOAT(1)+ 0.25 ) +
     *      COS( fy(FLOAT(1)+0.75) ) * fyprim( FLOAT(1)+ 0.75 )
      betas(1) = 0.5 * rys/(fyprim(FLOAT(1)+0.5)*fyprim(FLOAT(1)+0.5))
c
      rys = COS( fy(FLOAT(jjp1)-0.25)) * fyprim( FLOAT(jjp1)-0.25 )
      beta (jjp1) = SQRT( 2./ rys )
      betas(jjp1) = 0.
c
c
      DO 1000 l = 1, iim
c
c    ....   boucle sur les  iim valeurs propres de la matrice  RL  .....
c    ....               qui sont toutes < ou = 0.                       ...
c
c
      IF( ABS(eigvrl(l) ).LT. 1.e-5 )  THEN
c
       PRINT*,'Cas mode constant en longitude l=',l
c
c   ----------------------------------------------
c   ---    valeur propre de  la mat. RL =  0.  ---
c   ----------------------------------------------
c
c
c   ...............  construction de la matrice  RM0  ...................
c   ...              RM0 est une matrice  tridiagonale               ....
c
c   ...  il y a jjm +1 val.propres et jjm+1 fonct. propres pour RM0  ....
c
         DO 18 j  = 1, jjp1
         DO 18 i  = 1, jjp1
         rm0(i,j) = 0.
18       CONTINUE
c
         DO 20 j = 2, jjm
         rm0(j,j) = - beta(j) * beta(j)*( betas(j-1) + betas(j) )
20       CONTINUE
         DO 22 j = 1, jjm
         rm0(j,j+1) = beta(j)*beta(j+1)*betas(j)
         rm0(j+1,j) = rm0(j,j+1)
22       CONTINUE
         rm0(1,1)       = - beta(1)*beta(1)*betas(1)
         rm0(jjp1,jjp1) = - beta(jjp1)*beta(jjp1)*betas(jjm)
c
         CALL jacobi( rm0,jjp1,jjp1,eigvrm0,eigfrm0,nrot )
c
c    ... on pourra utiliser le prog.  tqli  pour les matrices tridiag. ...
c
         CALL eigsrt( eigvrm0,eigfrm0,jjp1,jjp1 )
c
         CALL orthonorm(jjp1,jjp1,eigfrm0)
c
c
         DO 30    m = 1, jjp1
         DO 30    j = 1, jjp1
         psi(j,m,l) = eigfrm0(j,m) * beta(j)
30       CONTINUE
c
      ELSE
c
c   ...............................................................
c   .........   valeurs propres de  RL # 0.   .....................
c   ...............................................................
c
c   Aux poles, les fonctions propres sont nulles. On a jjm -1 fonctions
c   propres #  0 . pour chaque matrice RM . Les fonctions propres nulles
c   des poles correspondent a m = jjm et m= jjm +1 et sont stockees ds
c   psi(j,jjm,l) et psi(j,jjm+1,l) .
c   Les matrices  RM sont  tridiagonales .
c
c
         DO 48 j = 1 , jjm -1
         DO 48 i = 1 , jjm -1
         rm(i,j) = 0.
48       CONTINUE
c
         DO 50 j = 2, jjm
         rm(j-1,j-1) = eigvrl(l)/(COS(fy(FLOAT(j)))*COS(fy(FLOAT(j))))
     *                -beta(j)*beta(j)*(betas(j-1)+betas(j))
50       CONTINUE
         DO 52 j = 2, jjm -1
         rm(j-1,j) = beta(j)*beta(j+1)*betas(j)
         rm(j,j-1) = rm(j-1,j)
52       CONTINUE
c
c
         CALL jacobi( rm,jjm-1,jjm-1,eigvrm,eigfrm,nrot )
c
c      On pourra utiliser eventuellement  tqli pour les matrices tridiag.
c
         CALL eigsrt( eigvrm,eigfrm,jjm-1,jjm-1 )
c
         CALL orthonorm(jjm1,jjm1,eigfrm)
c
c
         DO 65 m = 1, jjm -1
         DO 60 j = 2, jjm
         psi(j,m,l) = eigfrm(j-1,m) * beta(j)
60       CONTINUE
         psi(1,m,l)    = 0.
         psi(jjp1,m,l) = 0.
65       CONTINUE
c
         DO 70 j = 1, jjp1
         psi(j,jjm,l ) = 0 .
         psi(j,jjp1,l) = 0.
70       CONTINUE
c
      END IF
c
1000     CONTINUE
c
         RETURN
         END
c *=*=*=*= orthonorm.html =*=*=*=*
SUBROUTINE orthonorm

SUBROUTINE orthonorm


       SUBROUTINE orthonorm (  ni,nj,eigf )
c
       IMPLICIT NONE
c
c      P.Le Van
c
c   .....................................................................
c   ... Test de l'orthonormalisation des fonctions eigf (en colonnes ) ..
c
       REAL  eigf( ni,nj )
       REAL s,prec
       INTEGER i,k,m,ni,nj
c
       prec = 1.e-5
c
       DO 10 k = 1, nj
       m=k
5      CONTINUE
       s=0.
       DO 7 i = 1, ni
       s = s + eigf(i,k)*eigf(i,m)
7      CONTINUE
c
       IF(k.EQ.m) THEN
         IF((ABS(s)-1.).GT.prec) PRINT *,' orthonorm. # 1.',k,m,s
       ELSE
         IF(ABS(s).GT.prec) PRINT *,' orthonorm. # 0. ',k,m,s
       ENDIF
c
       m=m+1
       IF(m.GT.nj)GO TO 10
       GO TO 5
10     CONTINUE
c
       RETURN
       END
c *=*=*=*= eigsrt.html =*=*=*=*
SUBROUTINE eigsrt

SUBROUTINE eigsrt


       SUBROUTINE eigsrt(d,v,n,np)
       DIMENSION d(np),v(np,np)
       DO 13 i=1,n-1
       k=i
       p=d(i)
       DO 11 j=i+1,n
       IF(d(j).GE.p) THEN
       k=j
       p=d(j)
       ENDIF
 11    CONTINUE
       IF(k.NE.i)THEN
       d(k)=d(i)
       d(i)=p
       DO 12 j=1,n
       p=v(j,i)
       v(j,i)=v(j,k)
       v(j,k)=p
12     CONTINUE
       ENDIF
13     CONTINUE
       RETURN
       END
*=*=*=*= JACOBI.html =*=*=*=*
SUBROUTINE JACOBI

SUBROUTINE JACOBI


      SUBROUTINE JACOBI(A,N,NP,D,V,NROT)
      PARAMETER (nmax=200)
      DIMENSION A(NP,NP),D(NP),V(NP,NP),B(nmax),Z(nmax)
      IF (n.gt.nmax) THEN
         print*, 'n, nmax=', n, nmax
         print*, 'Surdimensionnement insuffisant dans jacobi'
         CALL abort
      ENDIF
      DO 12 IP=1,N
        DO 11 IQ=1,N
          V(IP,IQ)=0.
11      CONTINUE
        V(IP,IP)=1.
12    CONTINUE
      DO 13 IP=1,N
        B(IP)=A(IP,IP)
        D(IP)=B(IP)
        Z(IP)=0.
13    CONTINUE
      NROT=0
      DO 24 I=1,50
        SM=0.
        DO 15 IP=1,N-1
          DO 14 IQ=IP+1,N
            SM=SM+ABS(A(IP,IQ))
14        CONTINUE
15      CONTINUE
        IF(SM.EQ.0.)RETURN
        IF(I.LT.4)THEN
          TRESH=0.2*SM/N**2
        ELSE
          TRESH=0.
        ENDIF
        DO 22 IP=1,N-1
          DO 21 IQ=IP+1,N
            G=100.*ABS(A(IP,IQ))
            IF((I.GT.4).AND.(ABS(D(IP))+G.EQ.ABS(D(IP)))
     *         .AND.(ABS(D(IQ))+G.EQ.ABS(D(IQ))))THEN
              A(IP,IQ)=0.
            ELSE IF(ABS(A(IP,IQ)).GT.TRESH)THEN
              H=D(IQ)-D(IP)
              IF(ABS(H)+G.EQ.ABS(H))THEN
                T=A(IP,IQ)/H
              ELSE
                THETA=0.5*H/A(IP,IQ)
                T=1./(ABS(THETA)+SQRT(1.+THETA**2))
                IF(THETA.LT.0.)T=-T
              ENDIF
              C=1./SQRT(1+T**2)
              S=T*C
              TAU=S/(1.+C)
              H=T*A(IP,IQ)
              Z(IP)=Z(IP)-H
              Z(IQ)=Z(IQ)+H
              D(IP)=D(IP)-H
              D(IQ)=D(IQ)+H
              A(IP,IQ)=0.
              DO 16 J=1,IP-1
                G=A(J,IP)
                H=A(J,IQ)
                A(J,IP)=G-S*(H+G*TAU)
                A(J,IQ)=H+S*(G-H*TAU)
16            CONTINUE
              DO 17 J=IP+1,IQ-1
                G=A(IP,J)
                H=A(J,IQ)
                A(IP,J)=G-S*(H+G*TAU)
                A(J,IQ)=H+S*(G-H*TAU)
17            CONTINUE
              DO 18 J=IQ+1,N
                G=A(IP,J)
                H=A(IQ,J)
                A(IP,J)=G-S*(H+G*TAU)
                A(IQ,J)=H+S*(G-H*TAU)
18            CONTINUE
              DO 19 J=1,N
                G=V(J,IP)
                H=V(J,IQ)
                V(J,IP)=G-S*(H+G*TAU)
                V(J,IQ)=H+S*(G-H*TAU)
19            CONTINUE
              NROT=NROT+1
            ENDIF
21        CONTINUE
22      CONTINUE
        DO 23 IP=1,N
          B(IP)=B(IP)+Z(IP)
          D(IP)=B(IP)
          Z(IP)=0.
23      CONTINUE
24    CONTINUE
      STOP '50 iterations should never happen'
      RETURN
      END
*=*=*=*= TQLI.html =*=*=*=*
SUBROUTINE TQLI

SUBROUTINE TQLI


      SUBROUTINE TQLI(D,E,N,NP,Z)
      DIMENSION D(NP),E(NP),Z(NP,NP)
      IF (N.GT.1) THEN
        DO 11 I=2,N
          E(I-1)=E(I)
11      CONTINUE
        E(N)=0.
        DO 15 L=1,N
          ITER=0
1         DO 12 M=L,N-1
            DD=ABS(D(M))+ABS(D(M+1))
            IF (ABS(E(M))+DD.EQ.DD) GO TO 2
12        CONTINUE
          M=N
2         IF(M.NE.L)THEN
            IF(ITER.EQ.30)PAUSE 'too many iterations'
            ITER=ITER+1
            G=(D(L+1)-D(L))/(2.*E(L))
            R=SQRT(G**2+1.)
            G=D(M)-D(L)+E(L)/(G+SIGN(R,G))
            S=1.
            C=1.
            P=0.
            DO 14 I=M-1,L,-1
              F=S*E(I)
              B=C*E(I)
              IF(ABS(F).GE.ABS(G))THEN
                C=G/F
                R=SQRT(C**2+1.)
                E(I+1)=F*R
                S=1./R
                C=C*S
              ELSE
                S=F/G
                R=SQRT(S**2+1.)
                E(I+1)=G*R
                C=1./R
                S=S*C
              ENDIF
              G=D(I+1)-P
              R=(D(I)-G)*S+2.*C*B
              P=S*R
              D(I+1)=G+P
              G=C*R-B
              DO 13 K=1,N
                F=Z(K,I+1)
                Z(K,I+1)=S*Z(K,I)+C*F
                Z(K,I)=C*Z(K,I)-S*F
13            CONTINUE
14          CONTINUE
            D(L)=D(L)-P
            E(L)=G
            E(M)=0.
            GO TO 1
          ENDIF
15      CONTINUE
      ENDIF
      RETURN
      END