*=*=*=*= harmspher.html =*=*=*=*
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 ENDc *=*=*=*= orthonorm.html =*=*=*=*
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 ENDc *=*=*=*= eigsrt.html =*=*=*=*
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(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(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