#if defined(DOC)
!-------------------------------------- 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 --------------------------------------
#endif
#ifdef NEWTHERMO
! DEFINITION DES FONCTIONS THERMODYNAMIQUES DE BASE
! POUR LES CONSTANTES, UTILISER LE COMMON /CONSPHY/
! NOTE: TOUTES LES FONCTIONS TRAVAILLENT AVEC LES UNITES S.I.
! I.E. TTT EN DEG K, PRS EN PA, QQQ EN KG/KG
! *** N. BRUNET - MAI 90 ***
! * REVISION 01 - MAI 94 - N. BRUNET
! NOUVELLE VERSION POUR FAIBLES PRESSIONS
! * REVISION 02 - AOUT 2000 - J-P TOVIESSI
! CALCUL EN REAL*8
! * REVISION 03 - SEPT 2000 - N. BRUNET
! AJOUT DE NOUVELLES FONCTIONS
! * REVISION 04 - JANV 2000 - J. MAILHOT
! FONCTIONS EN PHASE MIXTE
! * REVISION 05 - DEC 2001 - G. LEMAY
! DOUBLE PRECISION POUR PHASE MIXTE
! * REVISION 06 - AVR 2002 - A. PLANTE
! AJOUT DES NOUVELLES FONCTIONS FOTTVH ET FOTVHT
! * REVISION 07 - OCT 2004 - B. BILODEAU
! NOUVEAU FORMAT POUR COMPILATION AVEC FICHIERS .ftn90
!
! FONCTION DE TENSION DE VAPEUR SATURANTE (TETENS) - EW OU EI SELON TT
REAL*8 FUNCTION FOEW (TTT) 15
REAL TTT
REAL*8 T2
T2 = DBLE(TTT)
IF (TTT.GT.TRPL) THEN
FOEW = 610.78D0*DEXP(17.269D0*(T2-DBLE(TRPL))/(T2-35.86D0))
ELSE
FOEW = 610.78D0*DEXP(21.875D0*(T2-DBLE(TRPL))/(T2-7.66D0))
ENDIF
END FUNCTION FOEW
! FONCTION CALCULANT LA DERIVEE SELON T DE LN EW (OU LN EI)
REAL*8 FUNCTION FODLE(TTT) 5
REAL TTT
REAL*8 TEMPO
IF (TTT.GT.TRPL) THEN
TEMPO=DBLE(TTT)-35.86D0
FODLE=17.269D0*(DBLE(TRPL)-35.86D0)/(TEMPO*TEMPO)
ELSE
TEMPO=DBLE(TTT)-7.66D0
FODLE=21.875D0*(DBLE(TRPL)-7.66D0)/(TEMPO*TEMPO)
ENDIF
END FUNCTION FODLE
! FONCTION CALCULANT L'HUMIDITE SPECIFIQUE SATURANTE (QSAT)
REAL*8 FUNCTION FOQST (TTT,PRS) 50,1
REAL TTT,PRS
FOQST = DBLE(EPS1)/(DMAX1(1.D0,DBLE(PRS)/FOEW
(TTT))- DBLE(EPS2))
END FUNCTION FOQST
! FONCTION CALCULANT LA DERIVEE DE QSAT SELON T
! QST EST LA SORTIE DE FOQST
REAL*8 FUNCTION FODQS(QST,TTT) 27,1
REAL QST,TTT
FODQS=DBLE(QST)*(1.D0+DBLE(DELTA)*DBLE(QST))*FODLE(TTT)
END FUNCTION FODQS
! FONCTION CALCULANT TENSION VAP (EEE) FN DE HUM SP (QQQ) ET PRS
REAL*8 FUNCTION FOEFQ(QQQ,PRS) 12
REAL QQQ,PRS
REAL*8 P2,Q2
Q2 = DBLE(QQQ)
P2 = DBLE(PRS)
FOEFQ = DMIN1(P2,(Q2*P2)/(DBLE(EPS1)+DBLE(EPS2)*Q2))
END FUNCTION FOEFQ
! FONCTION CALCULANT HUM SP (QQQ) DE TENS. VAP (EEE) ET PRES (PRS)
REAL*8 FUNCTION FOQFE(EEE,PRS) 11
REAL EEE,PRS
REAL*8 E2
E2=DBLE(EEE)
FOQFE=DMIN1(1.D0,DBLE(EPS1)*E2/(DBLE(PRS)-DBLE(EPS2)*E2))
END FUNCTION FOQFE
! FONCTION CALCULANT TEMP VIRT. (TVI) DE TEMP (TTT) ET HUM SP (QQQ)
REAL*8 FUNCTION FOTVT(TTT,QQQ) 37
REAL TTT,QQQ
FOTVT = DBLE(TTT) * (1.0D0 + DBLE(DELTA)*DBLE(QQQ))
END FUNCTION FOTVT
! FONCTION CALCULANT TEMP VIRT. (TVI) DE TEMP (TTT), HUM SP (QQQ) ET
! MASSE SP DES HYDROMETEORES.
REAL*8 FUNCTION FOTVHT(TTT,QQQ,QQH) 2
REAL TTT,QQQ,QQH
FOTVHT = DBLE(TTT) * (1.0D0 + DBLE(DELTA)*DBLE(QQQ) - DBLE(QQH))
END FUNCTION FOTVHT
! FONCTION CALCULANT TTT DE TEMP VIRT. (TVI) ET HUM SP (QQQ)
REAL*8 FUNCTION FOTTV(TVI,QQQ) 23
REAL TVI,QQQ
FOTTV = DBLE(TVI) / (1.0D0 + DBLE(DELTA)*DBLE(QQQ))
END FUNCTION FOTTV
! FONCTION CALCULANT TTT DE TEMP VIRT. (TVI), HUM SP (QQQ) ET
! MASSE SP DES HYDROMETEORES (QQH)
REAL*8 FUNCTION FOTTVH(TVI,QQQ,QQH) 2
REAL TVI,QQQ,QQH
FOTTVH = DBLE(TVI) / (1.0D0 + DBLE(DELTA)*DBLE(QQQ) - DBLE(QQH))
END FUNCTION FOTTVH
! FONCTION CALCULANT HUM REL DE HUM SP (QQQ), TEMP (TTT) ET PRES (PRS)
REAL*8 FUNCTION FOHR(QQQ,TTT,PRS) 4,2
REAL QQQ,TTT,PRS
! HR = E/ESAT
FOHR = DMIN1(DBLE(PRS),FOEFQ(QQQ,PRS)) / FOEW(TTT)
END FUNCTION FOHR
! FONCTION CALCULANT LA CHALEUR LATENTE DE CONDENSATION
REAL*8 FUNCTION FOLV(TTT) 5
REAL TTT
FOLV =DBLE(CHLC) - 2317.D0*(DBLE(TTT)-DBLE(TRPL))
END FUNCTION FOLV
! FONCTION CALCULANT LA CHALEUR LATENTE DE SUBLIMATION
REAL*8 FUNCTION FOLS(TTT) 4
REAL TTT
REAL*8 T2
T2 = DBLE(TTT)
FOLS=DBLE(CHLC)+DBLE(CHLF)+(DBLE(CPV)-(7.24D0*T2+128.4D0))*(T2-DBLE(TRPL))
END FUNCTION FOLS
! FONCTION RESOLVANT L'EQN. DE POISSON POUR LA TEMPERATURE
! NOTE: SI PF=1000*100, "FOPOIT" DONNE LE THETA STANDARD
REAL*8 FUNCTION FOPOIT(T00,PR0,PF) 3
REAL T00,PR0,PF
FOPOIT = DBLE(T00)*(DBLE(PR0)/DBLE(PF))**(-DBLE(CAPPA))
END FUNCTION FOPOIT
! FONCTION RESOLVANT L'EQN. DE POISSON POUR LA PRESSION
REAL*8 FUNCTION FOPOIP(T00,TF,PR0) 3
REAL T00,TF,PR0
FOPOIP=DBLE(PR0)*DEXP(-(DLOG(DBLE(T00)/DBLE(TF))/DBLE(CAPPA)))
END FUNCTION FOPOIP
! LES 5 FONCTIONS SUIVANTES SONT VALIDES DANS LE CONTEXTE OU ON
! NE DESIRE PAS TENIR COMPTE DE LA PHASE GLACE DANS LES CALCULS
! DE SATURATION.
! FONCTION DE VAPEUR SATURANTE (TETENS)
REAL*8 FUNCTION FOEWA (TTT) 19
REAL TTT
FOEWA=610.78D0*DEXP(17.269D0*(DBLE(TTT)-DBLE(TRPL))/(DBLE(TTT)-35.86D0))
END FUNCTION FOEWA
! FONCTION CALCULANT LA DERIVEE SELON T DE LN EW
REAL*8 FUNCTION FODLA(TTT) 8
REAL TTT
FODLA = 17.269D0*(DBLE(TRPL)-35.86D0)/(DBLE(TTT)-35.86D0)**2
END FUNCTION FODLA
! FONCTION CALCULANT L'HUMIDITE SPECIFIQUE SATURANTE
REAL*8 FUNCTION FOQSA(TTT,PRS) 43,1
REAL TTT,PRS
FOQSA = DBLE(EPS1)/(DMAX1(1.D0,DBLE(PRS)/FOEWA(TTT))-DBLE(EPS2))
END FUNCTION FOQSA
! FONCTION CALCULANT LA DERIVEE DE QSAT SELON T
REAL*8 FUNCTION FODQA(QST,TTT) 19,1
REAL QST,TTT
FODQA=DBLE(QST)*(1.D0+DBLE(DELTA)*DBLE(QST))*FODLA(TTT)
END FUNCTION FODQA
! FONCTION CALCULANT L'HUMIDITE RELATIVE
REAL*8 FUNCTION FOHRA(QQQ,TTT,PRS) 5,2
REAL QQQ,TTT,PRS
FOHRA = DMIN1(DBLE(PRS),FOEFQ(QQQ,PRS))/FOEWA(TTT)
END FUNCTION FOHRA
! Definition of basic thermodynamic functions in mixed-phase mode
! FFF is the fraction of ice and DDFF its derivative w/r to T
! NOTE: S.I. units are used
! i.e. TTT in deg K, PRS in Pa
! *** J. Mailhot - Jan. 2000 ***
! Saturation calculations in presence of liquid phase only
! Function for saturation vapor pressure (TETENS)
REAL*8 FUNCTION FESI(TTT) 8
REAL TTT
FESI=610.78D0*DEXP(21.875D0*(DBLE(TTT)-DBLE(TRPL))/(DBLE(TTT)-7.66D0))
END FUNCTION FESI
REAL*8 FUNCTION FDLESI(TTT) 4
REAL TTT
REAL*8 TEMPO
TEMPO = DBLE(TTT)-7.66D0
FDLESI=21.875D0*(DBLE(TRPL)-7.66D0)/(TEMPO*TEMPO)
END FUNCTION FDLESI
REAL*8 FUNCTION FESMX(TTT,FFF) 6,2
REAL TTT,FFF
FESMX = (1.D0-DBLE(FFF))*FOEWA(TTT)+DBLE(FFF)*FESI(TTT)
END FUNCTION FESMX
REAL*8 FUNCTION FDLESMX(TTT,FFF,DDFF) 8,5
REAL TTT,FFF,DDFF
REAL*8 D2,E1,F1,F2,M1
F2 = DBLE(FFF)
E1 = FOEWA(TTT)
F1 = FESI(TTT)
D2 = DBLE(DDFF)
M1 = FESMX(TTT,FFF)
FDLESMX=((1.D0-F2)*E1*FODLA(TTT)+F2*F1*FDLESI(TTT)+D2*(F1-E1))/M1
END FUNCTION FDLESMX
REAL*8 FUNCTION FQSMX(TTT,PRS,FFF) 12,1
REAL TTT,PRS,FFF
FQSMX=DBLE(EPS1)/(DMAX1(1.D0,DBLE(PRS)/FESMX(TTT,FFF))-DBLE(EPS2))
END FUNCTION FQSMX
REAL*8 FUNCTION FDQSMX(QSM,DLEMX) 9
REAL QSM,DLEMX
FDQSMX = DBLE(QSM)*(1.D0+DBLE(DELTA)*DBLE(QSM))*DBLE(DLEMX)
END FUNCTION FDQSMX
#else
SUBROUTINE THERMOBIDON
END SUBROUTINE THERMOBIDON
#endif