*=*=*=*= initestdyn.html =*=*=*=*
PROGRAM initestdyn IMPLICIT NONE c======================================================================= c c creation d'un etat initial c c======================================================================= c c----------------------------------------------------------------------- c declarations: c ------------- #include "dimensions.h" #include "paramet.h" #include "comconst.h" #include "comvert.h" #include "comgeom2.h" #include "control.h" #include "logic.h" #include "drsdef.h" #include "ener.h" REAL vcov(iip1,jjm,llm),ucov(iip1,jjp1,llm),u(iip1,jjp1,llm) REAL um(jjp1,llm) REAL h(iip1,jjp1,llm),pext(iip1,jjp1) REAL pks(iip1,jjp1),pksf(iip1,jjp1) REAL phis(iip1,jjp1) REAL teq(iip1,jjp1,llm) REAL w(iip1,jjp1,llm+1) REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) REAL dv(ip1jm,llm),du(ip1jmp1,llm) REAL dh(ip1jmp1,llm),dp(ip1jmp1) REAL q(iip1,jjp1,llm,nqmx) INTEGER iq c INTEGER i,j,l,itau,ig,idum INTEGER*4 day0 INTEGER unit REAL p(iip1,jjp1),phis0,zz,fact REAL t(iip1,jjp1,llm) REAL phi(iip1,jjp1,llm) REAL xx REAL daydeb logical startdrs EXTERNAL RAN1 REAL RAN1 EXTERNAL iniconst,geopot,inigeom,inifis INTEGER aslun, cllun INTEGER ierr, nbetat c c----------------------------------------------------------------------- c initialisations: c ---------------- c startdrs=.true. rad=6400000. omeg=4.*asin(1.)/(24.*3600.) g=9.8 mugaz=28. kappa=.2857 day_step=180 daysec=86400. c----------------------------------------------------------------------- CALL defrun(5) CALL iniconst CALL inigeom CALL inifilr PRINT*,'dtvr ',dtvr idum=-1 xx=RAN1(idum) idum=0 c----------------------------------------------------------------------- c PRINT*,'itau ',itau c phis0=0. c CALL inirappel(teq) DO l=1,llm DO j=1,jjp1 DO i=1,iim h(i,j,l)=teq(i,j,l) ENDDO ENDDO DO j=2,jjm DO i=1,iim h(i,j,l)=h(i,j,l)+COS(rlatu(j))*(RAN1(idum)-.5) ENDDO ENDDO DO j=1,jjp1 h(iip1,j,l)=h(1,j,l) ENDDO ENDDO c DO j=1,jjp1 DO i=1,iim phis(i,j)=phis0 p(i,j)=1000. ENDDO phis(iip1,j)=phis(1,j) p(iip1,j)=p(1,j) ENDDO DO 112 j=2,jjm DO 113 i=1,iim phis(i,j)=phis(i,j)+g*50.*(RAN1(idum)-1.)*COS(rlatu(j)) 113 CONTINUE phis(iip1,j)=phis(1,j) 112 CONTINUE c----------------------------------------------------------------------- c On calcul h,ts,pks,pksf,pext: c ----------------------------- DO 50 j=1,jjp1 DO 51 i=1,iip1 pext(i,j)=p(i,j)*aire(i,j) 51 CONTINUE 50 CONTINUE CALL exner(ip1jmp1,pext,aire,pks,pksf) c----------------------------------------------------------------------- c calcul du vent geostrophique en equilibre avec Teq c a l'equateur, on applique un facteur cos4(lat) call geopot (iip1*jjp1,h, pks, phis, phi ) DO j=1,jjm fact=cos(rlatv(j)) fact=fact*fact fact=fact*fact fact=fact*fact fact=(1.-fact)/(2.*omeg*sin(rlatv(j))*(rlatu(j+1)-rlatu(j))) fact=-fact/rad DO l=1,llm DO i=1,iim u(i,j,l)=fact*(phi(i,j+1,l)-phi(i,j,l)) um(j,l)=um(j,l)+u(i,j,l)/float(iim) ENDDO u(iip1,j,l)=u(1,j,l) ENDDO ENDDO call dump2d(jjp1,llm,um,'Vent geostrophique') c c----------------------------------------------------------------------- c calcul des champ de vent: c ------------------------- DO 301 l=1,llm DO 302 i=1,iip1 ucov(i,1,l)=0. ucov(i,jjp1,l)=0. 302 CONTINUE DO 304 j=2,jjm DO 305 i=1,iim ucov(i,j,l) = u(i,j,l)*cu(i,j) 305 CONTINUE ucov(iip1,j,l)=ucov(1,j,l) 304 CONTINUE 301 CONTINUE print*,301 DO 401 l=1,llm DO 402 j=1,jjm DO 403 i=1,iim vcov(i,j,l) = 0. 403 CONTINUE vcov(iip1,j,l)=vcov(1,j,l) 402 CONTINUE 401 CONTINUE c---------------------------------------------------------- c calcul des champ de traceur: c --------------------------- DO iq =1, nqmx DO l=1,llm DO j=1,jjp1 DO i=1,iim q(i,j,l,iq)=0. ENDDO ENDDO ENDDO ENDDO q(8,6,1,1) = 100. q(8,6,1,nqmx) = 100. c----------------------------------------------------------------------- c ecriture du fichier de demarrage: c -------------------------------- etot0=0. ptot0=0. stot0=0. ztot0=0. ang0=0. 147 CONTINUE daysec=86400. unit=12 c----------------------------------------------------------------------- c ecriture du fichier de demarrage: c -------------------------------- c CALL caldyn $ (0,ucov,vcov,h,pext,pks,pksf,phis, $ phi,.true.,du,dv,dh,dp,w, pbaru,pbarv,0.) PRINT*,'ptot,rmsdpdt,etot,ztot,stot,rmsv,ang' PRINT *, ptot,rmsdpdt,etot,ztot,stot,rmsv,ang c----------------------------------------------------------------------- unit=12 IF(startdrs) THEN ierr = aslun(unit,'start.dic', . unit+1,'start.dat',IDRS_CREATE) ELSE OPEN(unit,file='start',form='unformatted',status='new', . iostat=ierr) ENDIF if (ierr.ne.0) then write(6,*)' Pb d''ouverture du fichier restart' write(6,*)' ierr = ', ierr call exit(1) endif day0=0 CALL iniwrite(unit,startdrs,day0,phis) zz=0. call writedem(unit,nqmx,startdrs,zz,vcov,ucov,h,q,pext, . phis,nbetat) ierr = cllun(unit) end