*=*=*=*= testdyn.html =*=*=*=*
PROGRAM testdyn IMPLICIT NONE c======================================================================= c c Auteur: P. Le Van/ L.Fairhead/F.Hourdin c ------- c c Objet: c ------ c c GCM LMD nouvelle grille c c======================================================================= c ... modification de l'integration de q ( 26/04/94 ) .... c----------------------------------------------------------------------- c Declarations: c ------------- #include "dimensions.h" #include "paramet.h" #include "comconst.h" #include "comdissip.h" #include "comvert.h" #include "comgeom.h" #include "logic.h" #include "temps.h" #include "control.h" #include "ener.h" #include "description.h" INTEGER*4 iday ! jour julien REAL time ! Heure de la journee en fraction d'1 jour REAL zdtvr INTEGER nbetatmoy, nbetatdem,nbetat INTEGER ierr, aslun, cllun c variables dynamiques REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants REAL h(ip1jmp1,llm) ! temperature potentielle REAL pext(ip1jmp1) ! pression extensive REAL pks(ip1jmp1),pksf(ip1jmp1) ! exner (f pour filtre) REAL phis(ip1jmp1) ! geopotentiel au sol REAL phi(ip1jmp1,llm) ! geopotentiel REAL w(ip1jmp1,llm) ! vitesse verticale REAL q(ip1jmp1,llm,nqmx) ! champs advectes c z.x.li REAL qm1(ip1jmp1,llm,nqmx) REAL dq(ip1jmp1,llm,nqmx) c variables dynamiques intermediaire pour le transport REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) !flux de masse c variables dynamiques au pas -1 REAL vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm) REAL hm1(ip1jmp1,llm),pextm1(ip1jmp1) c z.x.li REAL qm1(ip1jmp1,llm,nqmx) c tendances dynamiques REAL dv(ip1jm,llm),du(ip1jmp1,llm) REAL dh(ip1jmp1,llm),dp(ip1jmp1) c tendances de la dissipation REAL dvdis(ip1jm,llm),dudis(ip1jmp1,llm) REAL dhdis(ip1jmp1,llm) c tendances physiques REAL dvfi(ip1jm,llm),dufi(ip1jmp1,llm) REAL dhfi(ip1jmp1,llm),dqfi(ip1jmp1,llm,nqmx),dpfi(ip1jmp1) c rappel Newtonnien REAL teq(ip1jmp1,llm) ! temperature de rappel REAL cterad ! constante de temps c variables pour le fichier histoire REAL dtav ! intervalle de temps elementaire INTEGER taphistd,taprstar,taphmoy,tapphys INTEGER itau,itaufinp1,iav,ij,l,idum EXTERNAL caldyn EXTERNAL dissip,geopot,iniconst,inifilr,ecriba EXTERNAL integrd,lectba,SCOPY EXTERNAL iniav EXTERNAL inigeom EXTERNAL exner,addit REAL time_0 , finvpold(ip1jmp1),xx,ran1 c----------------------------------------------------------------------- c Initialisations: c ---------------- c quelques constantes pour la dissipation tetavel=5000. tetatemp=5000. niterdis=2 lstardis=.false. grireg=.true. descript='Test DRS sur testdyn' rad=6400000. g=9.8 r=8.314*1000./28. mugaz=28. kappa=.2857 day_step=180 daysec=86400. omeg=4.*asin(1.)/daysec CALL defrun(5) c on recalcule eventuellement le pas de temps IF(MOD(day_step,iperiod).NE.0) sSTOP'Il faut choisir un nb de pas par jour multiple de iperiod' zdtvr = daysec/float(day_step) IF(dtvr.NE.zdtvr) THEN PRINT*,'WARNING!!! changement de pas de temps',dtvr,'>',zdtvr ENDIF c nombre d'etats dans les fichiers demarrage et histoire nbetatdem = nday / iecri nbetatmoy = nday / periodav + 1 dtvr=zdtvr c constantes CALL iniconst c intialisation de la geometrie CALL inigeom c initialisation du filtre CALL inifilr c----------------------------------------------------------------------- c initialisation de la temperature de rappel: c ------------------------------------------- c cinitialisation de la temperature de rappel Newtonnien CALL inirappel(teq) cterad=dtvr/(30.*daysec) idum=-1 xx=RAN1(idum) c pression extensive au sol do ij=1,ip1jmp1 pext(ij)=100000.*aire(ij) phis(ij)=0. enddo CALL exner(ip1jmp1,pext,aire,pks,pksf) c intialisation du vent et de la temperature do l=1,llm do ij=1,ip1jmp1 ucov(ij,l)=0. h(ij,l)=cpp*(250. . +COS(rlatu((ij-1)/iip1+1))*(RAN1(idum)-.5)) . /(pks(ij)*s(l)) enddo do ij=1,ip1jm vcov(ij,l)=0. enddo enddo call scopy(jjp1*llm,h,iip1,h(iip1,1),iip1) c intialisation de la dissipation horizontale CALL inidissip(lstardis,niterdis,tetavel,tetatemp) c----------------------------------------------------------------------- c temps de depart et de fin: c -------------------------- itau=0 iday=day_ini+itau/day_step time=FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0 IF(time.GT.1.) THEN time=time-1. iday=iday+1 ENDIF itaufin = nday*day_step itaufinp1 = itaufin +1 day_end=day_ini+nday PRINT 300, itau,itaufin,day_ini,day_end ecripar = .true. dtav=iperiod*dtvr/daysec c----------------------------------------------------------------------- c Debut de l'integration temporelle: c ---------------------------------- print*,'DT',dtvr 1 CONTINUE CALL SCOPY( ijmllm,vcov,1,vcovm1,1 ) CALL SCOPY( ijp1llm,ucov,1,ucovm1,1 ) CALL SCOPY( ijp1llm,h,1,hm1,1 ) CALL SCOPY( ip1jmp1,pext,1,pextm1,1 ) c z.x.li CALL SCOPY( ijp1llm*nqmx,q,1,qm1,1 ) forward = .true. leapf = .false. dt = dtvr c ... P.Le Van .26/04/94 .... CALL SCOPY ( ip1jmp1,pext,1,finvpold,1 ) CALL filtreg ( finvpold ,jjp1, 1, -2,2, .TRUE., 1 ) 2 CONTINUE c----------------------------------------------------------------------- c date: c ----- c gestion des appels de la physique et des dissipations: c ------------------------------------------------------ apphys = .false. statcl = .false. conser = .false. apdiss = .false. IF( MOD(itau ,iconser) .eq. 0 ) conser = .true. IF( MOD(itau+1,idissip) .eq. 0 ) apdiss = .true. IF( MOD(itau,iphysiq).eq.0.AND.forward $ .AND. physic ) apphys = .true. c----------------------------------------------------------------------- c calcul des tendances dynamiques: c -------------------------------- CALL geopot (ip1jmp1, h , pks , phis , phi ) CALL caldyn $ (itau,ucov,vcov,h,pext,pks,pksf,phis, $ phi,conser,du,dv,dh,dp,w, pbaru,pbarv, $ time+iday-day_ini) c----------------------------------------------------------------------- c integrations dynamique: c ----------------------- CALL integrd $ ( nqmx,vcovm1,ucovm1,hm1,pextm1, c z.x.li $ ( nqmx,vcovm1,ucovm1,hm1,qm1,pextm1, $ dv,du,dh,dq,dp, $ vcov,ucov,h,q,pext,phis,finvpold ) c .P.Le Van (26/04/94 ajout de finvpold dans l'appel d'integrd) c----------------------------------------------------------------------- c ajout des tendances physiques: c ------------------------------ c Ajout des tendances a chaque pas d'integration .... IF(physic) THEN DO l=1,llm DO ij=1,ip1jmp1 h(ij,l)=h(ij,l)-cterad*(h(ij,l)-teq(ij,l)) ENDDO ENDDO call friction(ucov,vcov,iphysiq*dtvr) ENDIF CALL exner(ip1jmp1,pext,aire,pks,pksf) c----------------------------------------------------------------------- c dissipation horizontal et verticales des petites echelles: c ---------------------------------------------------------- IF(apdiss) THEN CALL dissip(vcov,ucov,h,dvdis,dudis,dhdis) CALL addit(ijp1llm,ucov,dudis,ucov) CALL addit(ijmllm,vcov,dvdis,vcov) CALL addit(ijp1llm,h,dhdis,h) END IF c ******************************************************************** c ******************************************************************** c .... fin de l'integration dynamique et physique pour le pas itau .. c ******************************************************************** c ******************************************************************** c preparation du pas d'integration suivant ...... c ........................................................ c .............. schema matsuno + leapfrog .............. c ........................................................ IF(forward. OR. leapf) THEN itau= itau + 1 iday=day_ini+itau/day_step time=FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0 IF(time.GT.1.) THEN time=time-1. iday=iday+1 ENDIF ENDIF IF( itau. eq. itaufinp1 ) STOP c----------------------------------------------------------------------- c ecriture du fichier histoire moyenne: c ------------------------------------- IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN IF(itau.EQ.itaufin) THEN iav=1 ELSE iav=0 ENDIF ENDIF c----------------------------------------------------------------------- c ecriture de la bande histoire: c ------------------------------ IF( MOD(itau,iecri*day_step).eq.0) THEN nbetat = nbetatdem c ecriture des sorties call writeh(phis,ucov,vcov,h,pext,time) ENDIF IF(itau.EQ.itaufin) THEN c sauvegarde de l'etat initial a cet endroit ENDIF c----------------------------------------------------------------------- c gestion de l'integration temporelle: c ------------------------------------ IF( MOD(itau,iperiod).eq.0 ) THEN GO TO 1 ELSE IF ( MOD(itau-1,iperiod). eq. 0 ) THEN IF( forward ) THEN c fin du pas forward et debut du pas backward forward = .false. leapf = .false. GO TO 2 ELSE c fin du pas backward et debut du premier pas leapfrog leapf = .true. dt = 2.*dtvr GO TO 2 END IF ELSE c ...... pas leapfrog ..... leapf = .true. dt = 2.*dtvr GO TO 2 END IF 300 FORMAT('1'/15x'run du pas'i7,2x,'au pas'i7,2x, 'c"est a dire du * jour'i7,3x'au jour'i7//) STOP ENDc======================================================================= *=*=*=*= friction.html =*=*=*=*
SUBROUTINE friction(ucov,vcov,pdt) IMPLICIT NONE c======================================================================= c c c Objet: c ------ c c *********** c Friction c *********** c c======================================================================= #include "dimensions.h" #include "paramet.h" #include "comgeom2.h" #include "control.h" #include "comconst.h" REAL pdt REAL modv(iip1,jjp1),zco,zsi REAL vpn,vps,upoln,upols,vpols,vpoln REAL u2(iip1,jjp1),v2(iip1,jjm) REAL ucov( iip1,jjp1,llm ),vcov( iip1,jjm,llm ) INTEGER i,j REAL cfric parameter (cfric=1.e-6) c calcul des composantes au carre du vent naturel do j=1,jjp1 do i=1,iip1 u2(i,j)=ucov(i,j,1)*ucov(i,j,1)*unscu2(i,j) enddo enddo do j=1,jjm do i=1,iip1 v2(i,j)=vcov(i,j,1)*vcov(i,j,1)*unscv2(i,j) enddo enddo c calcul du module de V en dehors des poles do j=2,jjm do i=2,iip1 modv(i,j)=sqrt(0.5*(u2(i-1,j)+u2(i,j)+v2(i,j-1)+v2(i,j))) enddo modv(1,j)=modv(iip1,j) enddo c les deux composantes du vent au pole sont obtenues comme c premiers modes de fourier de v pres du pole upoln=0. vpoln=0. upols=0. vpols=0. do i=2,iip1 zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1)) zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1)) vpn=vcov(i,1,1)/cv(i,1) vps=vcov(i,jjm,1)/cv(i,jjm) upoln=upoln+zco*vpn vpoln=vpoln+zsi*vpn upols=upols+zco*vps vpols=vpols+zsi*vps enddo vpn=sqrt(upoln*upoln+vpoln*vpoln)/pi vps=sqrt(upols*upols+vpols*vpols)/pi do i=1,iip1 modv(i,1)=vpn modv(i,jjp1)=vps enddo c calcul du frottement au sol. do j=2,jjm do i=1,iim ucov(i,j,1)=ucov(i,j,1) s -cfric*pdt*0.5*(modv(i+1,j)+modv(i,j))*ucov(i,j,1) enddo ucov(iip1,j,1)=ucov(1,j,1) enddo do j=1,jjm do i=1,iip1 vcov(i,j,1)=vcov(i,j,1) s -cfric*pdt*0.5*(modv(i,j+1)+modv(i,j))*vcov(i,j,1) enddo enddo RETURN END*=*=*=*= writeh.html =*=*=*=*
subroutine writeh(phis,ucov,vcov,h,pext,time) implicit none #include "dimensions.h" #include "paramet.h" #include "comconst.h" #include "comvert.h" #include "comgeom2.h" REAL ucov(iip1,jjp1,llm),vcov(iip1,jjm,llm),h(iip1,jjp1,llm) REAL pext(iip1,jjp1) REAL phis(iip1,jjp1) REAL time INTEGER i,j,l INTEGER irec,isor,nout logical first save first,irec,isor,nout data first/.true./ data nout/88/ c variables meteo: c ---------------- REAL u(iip1,jjp1,llm),v(iip1,jjp1,llm),t(iip1,jjp1,llm) REAL pks(iip1,jjp1),pksf(iip1,jjp1) if(first) then OPEN (nout+1,FILE='hist.dat', . FORM='UNFORMATTED', & ACCESS='DIRECT',RECL=4*(iim+1)*(jjm+1)) first=.false. irec=1 isor=0 endif CALL exner(ip1jmp1,pext,aire,pks,pksf) do l=1,llm do j=1,jjp1 do i=1,iip1 t(i,j,l)=s(l)*h(i,j,l)*pks(i,j)/cpp enddo enddo enddo call covsnat(ucov,vcov,u,v) write(nout+1,rec=irec) ((pext(i,j)/aire(i,j),i=1,iip1) s,j=1,jjp1) irec=irec+1 do l=1,llm write(nout+1,rec=irec) ((u(i,j,l),i=1,iip1),j=1,jjp1) irec=irec+1 enddo do l=1,llm write(nout+1,rec=irec) ((v(i,j,l),i=1,iip1),j=1,jjp1) irec=irec+1 enddo do l=1,llm write(nout+1,rec=irec) ((t(i,j,l),i=1,iip1),j=1,jjp1) irec=irec+1 enddo isor=isor+1 c WARNING! on reecrase le fichier .ctl a chaque ecriture open(nout,file='hist.ctl',form='formatted',status='unknown') write(nout,*) 'DSET hist.dat' write(nout,*) 'UNDEF ',1.0E30 write(nout,*) 'FORMAT YREV' write(nout,*) 'TITLE ',' Test ' write(nout,*) 'XDEF ',iim+1,' LEVELS ' write(nout,'(7f8.2)') (rlonv(i)*180/pi,i=1,iim+1) write(nout,*) 'YDEF ',jjm+1,' LEVELS ' write(nout,'(7f8.2)') (rlatu(jjm+2-i)*180/pi,i=1,jjm+1) write(nout,'(a6,i4,a8)') 'ZDEF ',llm,' LEVELS ' write(nout,'(5f10.2)') (1000.*s(i)**(1./kappa),i=1,llm) write(nout,*) 'TDEF ',isor,' LINEAR 02JAN1987 1MO ' write(nout,*) 'VARS 4' write(nout,1000) 'ps ',0, 99,'Pression au sol' write(nout,1000) 'u ',llm, 99,'vent zonal' write(nout,1000) 'v ',llm, 99,'vent meridien' write(nout,1000) 't ',llm, 99,'temperature' write(nout,*) 'ENDVARS' close(nout) 1000 format(a9,i4,i3,x,a39) END*=*=*=*= covsnat.html =*=*=*=*
SUBROUTINE covsnat(ucov,vcov,u,v) IMPLICIT NONE c----------------------------------------------------------------------- c transformation du vent sur la grille scalaire pour les sorties c----------------------------------------------------------------------- c declarations: c ------------- #include "dimensions.h" #include "paramet.h" #include "comgeom2.h" #include "comconst.h" c arguments: c ---------- REAL vcov(iip1,jjm,llm),ucov(iip1,jjp1,llm) REAL u(iip1,jjp1,llm),v(iip1,jjp1,llm) c local: c ------ INTEGER npresmx PARAMETER (npresmx=llm) INTEGER i,j,l REAL z1(iip1),zcos(iip1),zsin(iip1) REAL zunord,zusud,zvnord,zvsud EXTERNAL writestd,interpol,geopot EXTERNAL SSUM REAL SSUM c----------------------------------------------------------------------- c vents: c ------ c 47. champs de vents aux pole nord c ------------------------------ c U = 1 / pi * integrale [ v * cos(long) * d long ] c V = 1 / pi * integrale [ v * sin(long) * d long ] DO l=1,llm z1(1)=(rlonu(1)-rlonu(iim)+2.*pi)*vcov(1,1,l)/cv(1,1) DO i=2,iim z1(i)=(rlonu(i)-rlonu(i-1))*vcov(i,1,l)/cv(i,1) ENDDO DO i=1,iim zcos(i)=COS(rlonv(i))*z1(i) zsin(i)=SIN(rlonv(i))*z1(i) ENDDO zunord=SSUM(iim,zcos,1)/pi zvnord=SSUM(iim,zsin,1)/pi c 48. champs de vents aux pole sud: c --------------------------------- c U = 1 / pi * integrale [ v * cos(long) * d long ] c V = 1 / pi * integrale [ v * sin(long) * d long ] z1(1)=(rlonu(1)-rlonu(iim)+2.*pi)*vcov(1,jjm,l)/cv(1,jjm) DO i=2,iim z1(i)=(rlonu(i)-rlonu(i-1))*vcov(i,jjm,l)/cv(i,jjm) ENDDO DO i=1,iim zcos(i)=COS(rlonv(i))*z1(i) zsin(i)=SIN(rlonv(i))*z1(i) ENDDO zusud=SSUM(iim,zcos,1)/pi zvsud=SSUM(iim,zsin,1)/pi DO j=2,jjm DO i=2,iim u(i,j,l)= $ 0.5*(ucov(i,j,l)/cu(i,j)+ucov(i-1,j,l)/cu(i-1,j)) ENDDO u(1,j,l)= s 0.5*(ucov(1,j,l)/cu(1,j)+ucov(iim,j,l)/cu(iim,j)) u(iip1,j,l)=u(1,j,l) ENDDO DO i=1,iip1 u(i,1,l) = zunord*SIN(rlonv(i))-zvnord*COS(rlonv(i)) u(i,jjp1,l)=-zusud*SIN(rlonv(i))+zvsud*COS(rlonv(i)) v(i,1,l) = zunord*COS(rlonv(i))+zvnord*SIN(rlonv(i)) v(i,jjp1,l)= zusud*COS(rlonv(i))+zvsud*SIN(rlonv(i)) ENDDO DO j=2,jjm DO i=1,iip1 v(i,j,l)= $ 0.5*(vcov(i,j,l)/cv(i,j)+vcov(i,j-1,l)/cv(i,j-1)) ENDDO ENDDO enddo RETURN END