*=*=*=*= tracvl.html =*=*=*=*
SUBROUTINE tracvl(numvanle,iadvtrac,nq,pbaru,pbarv , * pextfil, q ) c c Auteur : F. Hourdin c IMPLICIT NONE c ......... Version du 29/04/97 ......... c #include "dimensions.h" #include "paramet.h" #include "comconst.h" #include "comvert.h" #include "comgeom.h" INTEGER nq,iadvtrac REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) REAL q(ip1jmp1,llm,nq),pextfil(ip1jmp1) REAL pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm) REAL pextm(ip1jmp1),zdp(ip1jmp1) REAL pbarug(ip1jmp1,llm),pbarvg(ip1jm,llm),wg(ip1jmp1,llm) REAL pextg(ip1jmp1) INTEGER izdpmin,izdpmax,ismin,ismax INTEGER iadvtr, numvanle INTEGER ij,l,iq SAVE iadvtr, pextm,pbaruc,pbarvc DATA iadvtr/0/ IF(iadvtr.EQ.0) THEN CALL initial0(ijp1llm,pbaruc) CALL initial0(ijmllm,pbarvc) ENDIF c accumulation des flux pour les autres quantites. DO l=1,llm DO ij=1,ip1jmp1 pbaruc(ij,l)=pbaruc(ij,l)+pbaru(ij,l) ENDDO DO ij=1,ip1jm pbarvc(ij,l)=pbarvc(ij,l)+pbarv(ij,l) ENDDO ENDDO IF(iadvtr.EQ.0) THEN CALL SCOPY(ip1jmp1,pextfil,1,pextm,1) ENDIF iadvtr=iadvtr+1 IF (iadvtr.EQ.iadvtrac) THEN CALL groupe(pextm,pbaruc,pbarvc,pextg,pbarug,pbarvg,wg) c test sur l'eventuelle creation de valeurs negatives de la masse DO l=1,llm DO ij=iip2+1,ip1jm zdp(ij)=dsig(l)*(pbarug(ij-1,l)-pbarug(ij,l) s -pbarvg(ij-iip1,l)+pbarvg(ij,l)) s +wg(ij,l+1)-wg(ij,l) ENDDO CALL SCOPY(jjp1,zdp(iip1),iip1,zdp,iip1) DO ij=iip2,ip1jm zdp(ij)=zdp(ij)*dtvr/(dsig(l)*pextg(ij)) ENDDO izdpmin=ismin(ip1jm-iip1,zdp(iip2),1)+iip1 izdpmax=ismax(ip1jm-iip1,zdp(iip2),1)+iip1 IF(max(abs(zdp(izdpmin)),abs(zdp(izdpmax))).gt.0.5) THEN PRINT*,'WARNING DP/P l=',l,' MIN:',izdpmin,zdp(izdpmin), s ' MAX:', s izdpmax,zdp(izdpmax) ENDIF ENDDO DO iq = numvanle, nq CALL vlsplt(q(1,1,iq),2.,pextg,wg,pbarug,pbarvg,dtvr) ENDDO iadvtr=0 c on reinitialise a zero les flux de masse cumules. ENDIF ! if iadvtr.EQ.iadvtrac RETURN END