Документ взят из кэша поисковой машины. Адрес оригинального документа : http://hea.iki.rssi.ru/conf/hea2007/presentations/after_dinner_speech/2-Two-Dim/2DVTZ.FFF Дата изменения: Sat Apr 8 18:16:22 2000 Дата индексирования: Tue Oct 2 03:24:37 2012 Кодировка:

C
C ** ****** **** ****
C ****** ****** ****** ******
C ** ** ** ** ** **
C ** **** ** ** ***
C ** *** **** ** ** *** *** *** ****
C ** ** ** ** ** ** * * * * * *
C ****** ****** ****** ****** ** * * * * * *
C **** ****** **** **** ** *** *** * * *
C
C
C PROGRAM GEOS
C PARAMETER (MX0=200,MY0=1,MZ0=20,MCQ=1,MTR=4)
COMMON /BQG/BQGM(12) /BSQ/BSQM(12)
COMMON /BL0/NS,NX,NY,NZ,DX,DY,DZ,DT,T,DTF
C /BLU/NZP,NPR,NST,NED,NTH,EVK,ETK,EDT,DTM,EEQ
C /BPF/IPR,JPR,KPR,MPR,LPR,MST,TPR,HPR,TZP,HZP
C /BMR/NMR,KMR,LMR,MMR,XMR,YMR,ZMR,SMR(3,10)
C /BLP/KPP,NPP,WAP,WAT,WAV(3),EET,EEV,EEP,EPS
C /BLC/HL0,HLT,SN0,SNT,HSN,QSN,HQ0,HQT,RAI,RAC
C /BLW/UX0,UY0,UZ0,AUX,AUY,AUZ,RHA,RHB,HHA,HHB
C /BLV/NET,NEV,NEP,ETT,EVT,EPT,ERT,ERK,GTT,SNN
C /BLT/TA0,TB0,ATA,ATB,T00,I00,J00,K00,CA0,CB0
C /BGR/KSA,KSB,KSC,KKM,QGA,QGB,QGC,QGD,QGE,QGF
C /BTR/NTR,NTT,NDT,NFS,ROT,FSA,THT,QVH,QHH,DHH
C********************************************************
COMMON /BVX/VX(&MM) /BVY/VY(&MM) /BVZ/VZ(&MM)
C /BUX/UX(&MM) /BUY/UY(&MM) /BUZ/UZ(&MM)
C /BWX/WX(&MM) /BWY/WY(&MM) /BWZ/WZ(&MM)
C /BPP/PP(&MM) /BTH/TH(&MM) /BSN/SN(&MM)
C /BRH/RH(&MM) /BCQ/CQ(&MQ)
C /BMA/QP(&ME) /BMB/QT(&ME) /BMC/PD(&ME)
C /BMD/OH(&ME) /BME/PS(&ME) /BMF/PH(&ME)
C /BUH/UH(&MC) /BVH/VH(&MC) /BWH/WH(&MC)
C /BVR/VR(&MB) /BUL/UL(&MA) /BWR/WR(&MC)
C /IST/IS(&MX) /JST/JS(&MY) /KST/KS(&MZ)
C /SIT/SI(&MX) /SJT/SJ(&MY) /SKT/SK(&MZ)
C /BXC/XC(300) /BYC/YC(300)
C /BXT/XT(&MT) /BYT/YT(&MT) /BMT/MT(&MR)
C /BUC/UC(&MR) /BVC/VC(&MR) /BWC/WC(&MR)
C /BX1/BX1(&MD) /BY1/BY1(&MD) /BZ1/BZ1(&MD)
C /BX4/BX4(&MD) /BY4/BY4(&MD) /BZ4/BZ4(&MD)
C /BX2/BX2(&MZ) /BY2/BY2(&MZ) /BZ2/BZ2(&MZ)
C /BX5/BX5(&MZ) /BY5/BY5(&MZ) /BZ5/BZ5(&MZ)
C /BLNAM/NAMEA,NAMEB /BLQ/NCQ,LCQ
CHARACTER*32 NAMEA,NAMEB,NAMEC
C =======================================================
C ===============>__Name_of_the_initial-data_file_<======
DATA NAMEC/'2dvtz.dat '/
C =======================================================
1 NAMEB=NAMEC;MMM=&MM-1;NCQ=(&MQ-1)/MMM
CALL SFIELD(&MX-2,&MY-2,&MZ-2,&MR,&MR+&MT)
CALL WRARES(6); CALL SPRING; IF(NED.EQ.0) GO TO 1
3 CALL TSTEPG; CALL TERRAG
C CALL DENSIT; CALL LIM3(RH,' RH ',MMM,MPR,4)
C CALL SEDIMG; CALL LIM3(CQ,' CQ ',MMM,MPR,4)
CALL LIM3(SN,' SQ ',MMM,MPR,4)
CALL TERMOG; CALL LIM3(TH,' TH ',MMM,MPR,4)
CALL LIM3(SN,' SL ',MMM,MPR,4)
4 CALL ACSELG; CALL LIM3(SN,' SM ',MMM,MPR,4)
CALL LIM3(UX,' QX ',MMM,MPR,4)
CALL LIM3(UY,' QY ',MMM,MPR,4)
CALL LIM3(UZ,' QZ ',MMM,MPR,4)
CALL PRESSG(1); CALL LIM3(PH,' PH ',MMM,MPR,4)
CALL LIM3(PP,' PP ',MMM,MPR,4)
CALL ELLIPG(2); CALL LIM3(UX,' UX ',MMM,MPR,4)
CALL LIM3(UY,' UY ',MMM,MPR,4)
CALL LIM3(UZ,' UZ ',MMM,MPR,4)
CALL OPTPRG; CALL LIM3(PH,' PH ',MMM,MPR,4)
C CALL PFF2D(VX,' VX ',1.,0.,NX,-NZ,NS,T)
C CALL PFF2D(VY,' VY ',1.,0.,NX,-NZ,NS,T)
C CALL PFF2D(VZ,' VZ ',1.,0.,NX,-NZ,NS,T)
IF(KSB.LT.0) GO TO 4
CALL DIVERG(0); CALL LIM3(PH,' PH ',MMM,MPR,4)
5 CALL MARKER(1); CALL CHDIMM(1)
IF(NZP.GT.0) CALL WRARES(1)
6 IF(NPR.GT.0) CALL SPRING; IF(NED) 3,1,7
7 STOP;END

FUNCTION FUNSL(TTT)
C CALCULATION OF TERMOCONDUCTIVITY
COMMON /BLC/HL0,HLT,SN0,SNT,HSN,QSN,HQ0,HQT,RAI,RAC
FUNSL=HL0+HLT*TTT
RETURN;END

FUNCTION FUNSQ(TTT)
C CALCULATION OF DIFFUSION COOFICIENT
COMMON /BLC/HL0,HLT,SN0,SNT,HSN,QSN,HQ0,HQT,RAI,RAC
C /BLQ/NCQ,LCQ; FUNSQ=HQ0+HQT*TTT
RETURN;END

FUNCTION FUNQT(TTT,CCC,X,Y,Z,T)
C SOURSE OF ENERGY (RIGHT SIDE IN TEMPERATURE EQUATION)
FUNQT=0.0+0.*(TTT+CCC+X+Y+Z+T)
RETURN;END

FUNCTION FUNSV(TTT,RHH,CQ,X,Y,Z) ! Rewrited 07-27-93 !
C CALCULATION OF VISCOSITY (JUMP F) !
COMMON /BL0/NS,NX,NY,NZ,DX,DY,DZ,DT,T,DTF
C /BLC/HL0,HLT,SN0,SNT,HSN,QSN,HQ0,HQT,RAI,RAC
C /BLW/UX0,UY0,UZ0,AUX,AUY,AUZ,RHA,RHB,HHA,HHB
C /BTR/NTR,NTT,NDT,NFS,ROT,FSA,THT,QVH,QHH,DHH
C IFCONT returns 0 if out of continents
C returns N - number of upper continent
SM=SN0*EXP(-4.6052*TTT+0.2*4.6052*(1-Z))
R0=RHH+CQ;HR=NZ*DZ-DHH
IF(Z.GT.HR.AND.IFCONT(X,Y).GE.1) SM=SM*100
C R1=RAI;R2=RAC;RAI=0.;RAC=-1.; GA=FUNGG(RHH,TTT,CQ,Z)
C RAI=R1;RAC=R2; FUNSV=0.1*SM*(1.+9.*GA)
FUNSV=SM
RETURN;END

FUNCTION FUNGG(RT,TT,CT,ZT)
C CALCULATION OF RIGHT SIDE DENSITY
C RAC* DENSITY RTN RAI* TEMPERATURE
COMMON /BZ5/BZ5(&MZ)
C /BLC/HL0,HLT,SN0,SNT,HSN,QSN,HQ0,HQT,RAI,RAC
C /BLW/UX0,UY0,UZ0,AUX,AUY,AUZ,RHA,RHB,HHA,HHB
C /BLT/TA0,TB0,ATA,ATB,T00,I00,J00,K00,CA0,CB0
C DATA Z0,T0,GM,E/0.7,0.3,-0.06,0.05/
C BZ5(1)=E; A=(Z0-ZT-GM*(TT-T0))/E; GA=RT+CT
C GA=0.; IF(A.GT.0.) GA=1.
FUNGG=RAI*TT
RETURN;END

FUNCTION FUNRH(XXX,YYY,ZZZ)
C DENSITY DISTRIBUTION AT THE BEGINING
COMMON /BL0/NS,NX,NY,NZ,DX,DY,DZ,DT,T,DTF
C /BLW/UX0,UY0,UZ0,AUX,AUY,AUZ,RHA,RHB,HHA,HHB
C DATA PI/3.14159/
C HH0=HHA*(1.+0.0*SIN(PI*XXX)*SIN(PI*YYY))
XC=0.5*NX*DX;YC=0.5*NY*DY;ZC=HHB
R=(XXX-XC)**2+(YYY-YC)**2+(ZZZ-ZC)**2
FUNRH=RHA; IF(SQRT(R).LE.HHA) FUNRH=RHB
RETURN;END

FUNCTION FUNTH(XXX,YYY,ZZZ)
C TEMPERATURE DISTRIBUTION AT THE BEGINING
COMMON /BL0/NS,NX,NY,NZ,DX,DY,DZ,DT,T,DTF
C /BLT/TA0,TB0,ATA,ATB,T00,I00,J00,K00,CA0,CB0
DATA PI/3.14159/; TTT=(TA0+ZZZ*(TB0-TA0)/(NZ*DZ))
FUNTH=AMAX1(0.,TTT)
C f=SIN((XXX+YYY)*PI/3)*SIN((XXX-YYY)*PI/3)
C f=f*f
C f1=SIN((XXX+YYY)*PI/3-PI/2)*SIN((XXX-YYY)*PI/3-PI/2)
C f1=f1*f1
C FUNTH=FUNTH*(1+0.1*(f-f1)*SIN(PI*ZZZ))
F=SIN(PI*ZZZ)*COS(PI*XXX)
FUNTH=FUNTH*(1+0.1*F)
RETURN;END

FUNCTION FUNCQ(XXX,YYY,ZZZ)
C CONCENTRATION DISTRIBUTION AT THE BEGINING
COMMON /BL0/NS,NX,NY,NZ,DX,DY,DZ,DT,T,DTF
C /BLT/TA0,TB0,ATA,ATB,T00,I00,J00,K00,CA0,CB0
C /BLQ/NCQ,LCQ; DATA PI/3.14159/
CCC=(CA0+ZZZ*(CB0-CA0)/(NZ*DZ))
FUNCQ=CCC*(1.+0.0*SIN(PI*XXX)*SIN(PI*YYY))
RETURN;END

FUNCTION FUNCI(TTT,HHH,RHH,CQQ)
C CONCENTRATION SORSERS IN RIGHT SIDE
COMMON /BL0/NS,NX,NY,NZ,DX,DY,DZ,DT,T,DTF
C /BLT/TA0,TB0,ATA,ATB,T00,I00,J00,K00,CA0,CB0
FUNCI=0.*(1.+TTT+HHH+RHH+CQQ)
RETURN;END

FUNCTION FUNSD(TTT,HHH,RHH,CQ)
C CONCENTRATION VELOCITY CALCULATION
COMMON /BL0/NS,NX,NY,NZ,DX,DY,DZ,DT,T,DTF
C /BLT/TA0,TB0,ATA,ATB,T00,I00,J00,K00,CA0,CB0
FUNSD=0.000+0.*(TTT+HHH+RHH+CQ)
RETURN;END

FUNCTION FUNVC(V0,KL)
COMMON /SIT/SIT(&MX) /SJT/SJT(&MY)
DIMENSION A(3); A(1)=SIT(1);A(2)=SJT(1)
A(3)=A(1)*A(2); FUNVC=V0*A(KL)
RETURN;END