!-------------------------------------- LICENCE BEGIN ------------------------------------ !Environment Canada - Atmospheric Science and Technology License/Disclaimer, ! version 3; Last Modified: May 7, 2008. !This is free but copyrighted software; you can use/redistribute/modify it under the terms !of the Environment Canada - Atmospheric Science and Technology License/Disclaimer !version 3 or (at your option) any later version that should be found at: !http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html ! !This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; !without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. !See the above mentioned License/Disclaimer for more details. !You should have received a copy of the License/Disclaimer along with this software; !if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec), !CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca !-------------------------------------- LICENCE END -------------------------------------- ***s/r Eigenabc_local - local eigenvalues and eigenvectors and inverse * tridiagonal coefficients For the preconditioning * #include "model_macros_f.h"*
subroutine eigenabc_local ( eval_local, evec_local, ai_local, 1,1 $ bi_local,ci_local,nil,njl,Ni,Nj,Nk,i0,j0,wk) implicit none * integer nil,njl,Ni,Nj,Nk,i0,j0 real*8 eval_local(Ni),evec_local(Ni,Ni),ai_local(Ni,Nj,Nk), $ bi_local(Ni,Nj,Nk),ci_local(Ni,Nj,Nk),wk(*) *author * Abdessamad Qaddouri - initial version - December 2006 * *revision * v3_30 - Qaddouri A. - initial version * #include "glb_ld.cdk"
#include "opr.cdk"
#include "sol.cdk"
* integer i,j,k,iloc,jloc,fni0,ii,jj real*8 a_8(Ni,Ni), b_8(Ni,Ni), c_8(Ni,Ni), d_8(3*Ni-1), $ r_8(Ni),di_8,zero,one,pdfaz,cst parameter(zero=0.d0,one=1.d0) real*8 fdg1(Ni,Ni),fdg2(Ni,Ni),fdg3(Ni,Ni), $ a_81(Ni,Nj),b_81(Ni,Nj),c_81(Ni,Nj) * * --------------------------------------------------------------- * a_8=zero ; b_8=zero ; fdg3=zero * iloc=0 do i = 1+sol_pil_w,nil-sol_pil_e-1 ii=i+i0-1 iloc=iloc+1 a_8(iloc,iloc+1) = Opr_opsxp2_8(2*G_ni+ii) a_8(iloc,iloc ) = Opr_opsxp2_8(G_ni+ii) a_8(iloc+1,iloc) = a_8(iloc,iloc+1) b_8(iloc,iloc+1) = Opr_opsxp0_8(2*G_ni+ii) b_8(iloc,iloc ) = Opr_opsxp0_8(G_ni+ii) b_8(iloc+1,iloc) = b_8(iloc,iloc+1) enddo a_8(Ni,Ni) = Opr_opsxp2_8(G_ni+(nil-sol_pil_e+i0-1)) b_8(Ni,Ni) = Opr_opsxp0_8(G_ni+(nil-sol_pil_e+i0-1)) * pdfaz=-One * fdg1=a_8 ; fdg2=b_8 * call prepoic
(r_8, a_8, b_8, d_8, pdfaz, -ONE, 'N', fni0, Ni, Ni ) * evec_local = a_8 eval_local = r_8 * do i = 1, Ni fdg3(i,i) = eval_local(i) end do * * inverse trid * do k=1,Nk * cst=wk(k) * iloc=0 do i = 1+sol_pil_w,nil-sol_pil_e iloc=iloc+1 jloc=0 do j=1+sol_pil_s,njl-sol_pil_n-1 jj=j+j0-1 jloc=jloc+1 di_8= Opr_opsyp0_8(G_nj+jj) / (cos( G_yg_8 (jj) )**2) b_81(iloc,jloc)=eval_local(iloc) * di_8 + $ Opr_opsyp2_8(G_nj+jj)+cst*Opr_opsyp0_8(G_nj+jj) c_81(iloc,jloc)=Opr_opsyp2_8(2*G_nj+jj) a_81(iloc,jloc+1)=c_81(iloc,jloc) enddo * jj=njl-sol_pil_n+j0-1 di_8= Opr_opsyp0_8(G_nj+jj) / (cos( G_yg_8 (jj)) **2) b_81(iloc,Nj)=eval_local(iloc)*di_8+Opr_opsyp2_8(G_nj+jj)+ $ cst*Opr_opsyp0_8(G_nj+jj) a_81(iloc,1 )= zero c_81(iloc,Nj) = zero if(Nj .gt. 1) a_81(iloc,Nj) =c_81(iloc, Nj-1) enddo * ai_local(:,:,k)=zero;bi_local(:,:,k)=zero;ci_local(:,:,k)=zero * do i=1,Ni bi_local(i,1,k)=b_81(i,1) ci_local(i,1,k)=c_81(i,1) enddo * do i=1,Ni do j=2,Nj ci_local(i,j,k)=c_81(i,j) ai_local(i,j,k)=a_81(i,j)/bi_local(i,j-1,k) bi_local(i,j,k)=b_81(i,j)-ai_local(i,j,k)*c_81(i,j-1) enddo enddo * enddo * * --------------------------------------------------------------- * return end