Head

GCC Code Coverage Report

Directory:	./		Exec	Total	Coverage
File:	phylmd/plevel_new.F90	Lines:	29	29	100.0 %
Date:	2023-06-30 12:56:34	Branches:	40	54	74.1 %



! $Header: /home/cvsroot/LMDZ4/libf/phylmd/plevel.F,v 1.1.1.1.10.1 2006/08/17
! 15:41:51 fairhead Exp $

! ================================================================
! ================================================================
SUBROUTINE plevel_new(ilon, ilev, klevstd, lnew, pgcm, pres, qgcm, qpres)
  ! ================================================================
  ! ================================================================
  USE netcdf
  USE dimphy
#ifdef CPP_IOIPSL
  USE phys_state_var_mod, ONLY: missing_val_nf90
#endif
#ifdef CPP_XIOS
  USE wxios, ONLY: missing_val
#endif

  IMPLICIT NONE

  ! ================================================================

  ! Interpoler des champs 3-D u, v et g du modele a un niveau de
  ! pression donnee (pres)

  ! INPUT:  ilon ----- nombre de points
  ! ilev ----- nombre de couches
  ! lnew ----- true si on doit reinitialiser les poids
  ! pgcm ----- pressions modeles
  ! pres ----- pression vers laquelle on interpolle
  ! Qgcm ----- champ GCM
  ! Qpres ---- champ interpolle au niveau pres

  ! ================================================================

  ! arguments :
  ! -----------

  INTEGER ilon, ilev, klevstd
  LOGICAL lnew

  REAL pgcm(ilon, ilev)
  REAL qgcm(ilon, ilev)
  REAL pres(klevstd)
  REAL qpres(ilon, klevstd)

  ! local :
  ! -------

  ! ym      INTEGER lt(klon), lb(klon)
  ! ym      REAL ptop, pbot, aist(klon), aisb(klon)

  ! ym      save lt,lb,ptop,pbot,aist,aisb
  INTEGER, ALLOCATABLE, SAVE, DIMENSION (:, :) :: lt, lb
  REAL, ALLOCATABLE, SAVE, DIMENSION (:, :) :: aist, aisb
  !$OMP THREADPRIVATE(lt,lb,aist,aisb)
  REAL, SAVE :: ptop, pbot
  !$OMP THREADPRIVATE(ptop, pbot)
  LOGICAL, SAVE :: first = .TRUE.
  INTEGER :: nlev
  !$OMP THREADPRIVATE(first)
  INTEGER i, k

! REAL missing_val
#ifndef CPP_XIOS
  REAL :: missing_val
#endif

! missing_val = nf90_fill_real

#ifndef CPP_XIOS
      missing_val=missing_val_nf90
#endif

  IF (first) THEN
    ALLOCATE (lt(klon,klevstd), lb(klon,klevstd))
    ALLOCATE (aist(klon,klevstd), aisb(klon,klevstd))
    first = .FALSE.
  END IF

  ! =====================================================================
  IF (lnew) THEN
    ! on reinitialise les reindicages et les poids
    ! =====================================================================


    ! Chercher les 2 couches les plus proches du niveau a obtenir

    ! Eventuellement, faire l'extrapolation a partir des deux couches
    ! les plus basses ou les deux couches les plus hautes:


    DO nlev = 1, klevstd
      DO i = 1, klon
        IF (abs(pres(nlev)-pgcm(i,ilev))<abs(pres(nlev)-pgcm(i,1))) THEN
          lt(i, nlev) = ilev ! 2
          lb(i, nlev) = ilev - 1 ! 1
        ELSE
          lt(i, nlev) = 2
          lb(i, nlev) = 1
        END IF
      END DO
      DO k = 1, ilev - 1
        DO i = 1, klon
          pbot = pgcm(i, k)
          ptop = pgcm(i, k+1)
          IF (ptop<=pres(nlev) .AND. pbot>=pres(nlev)) THEN
            lt(i, nlev) = k + 1
            lb(i, nlev) = k
          END IF
        END DO
      END DO

      ! Interpolation lineaire:
      DO i = 1, klon
        ! interpolation en logarithme de pression:

        ! ...   Modif . P. Le Van    ( 20/01/98) ....
        ! Modif Frederic Hourdin (3/01/02)

        aist(i, nlev) = log(pgcm(i,lb(i,nlev))/pres(nlev))/log(pgcm(i,lb(i, &
          nlev))/pgcm(i,lt(i,nlev)))
        aisb(i, nlev) = log(pres(nlev)/pgcm(i,lt(i,nlev)))/log(pgcm(i,lb(i, &
          nlev))/pgcm(i,lt(i,nlev)))
      END DO
    END DO

  END IF ! lnew

  ! ======================================================================
  ! inteprollation
  ! ET je mets les vents a zero quand je rencontre une montagne
  ! ======================================================================

  DO nlev = 1, klevstd
    DO i = 1, klon
      IF (pgcm(i,1)<pres(nlev)) THEN
        qpres(i, nlev) = missing_val
      ELSE
        qpres(i, nlev) = qgcm(i, lb(i,nlev))*aisb(i, nlev) + &
          qgcm(i, lt(i,nlev))*aist(i, nlev)
      END IF
    END DO
  END DO


  RETURN
END SUBROUTINE plevel_new


Generated by: GCOVR (Version 4.2)

Line	Branch	Exec	Source
1
2			! $Header: /home/cvsroot/LMDZ4/libf/phylmd/plevel.F,v 1.1.1.1.10.1 2006/08/17
3			! 15:41:51 fairhead Exp $
4
5			! ================================================================
6			! ================================================================
7		4896	SUBROUTINE plevel_new(ilon, ilev, klevstd, lnew, pgcm, pres, qgcm, qpres)
8			! ================================================================
9			! ================================================================
10			USE netcdf
11			USE dimphy
12			#ifdef CPP_IOIPSL
13			USE phys_state_var_mod, ONLY: missing_val_nf90
14			#endif
15			#ifdef CPP_XIOS
16			USE wxios, ONLY: missing_val
17			#endif
18
19			IMPLICIT NONE
20
21			! ================================================================
22
23			! Interpoler des champs 3-D u, v et g du modele a un niveau de
24			! pression donnee (pres)
25
26			! INPUT: ilon ----- nombre de points
27			! ilev ----- nombre de couches
28			! lnew ----- true si on doit reinitialiser les poids
29			! pgcm ----- pressions modeles
30			! pres ----- pression vers laquelle on interpolle
31			! Qgcm ----- champ GCM
32			! Qpres ---- champ interpolle au niveau pres
33
34			! ================================================================
35
36			! arguments :
37			! -----------
38
39			INTEGER ilon, ilev, klevstd
40			LOGICAL lnew
41
42			REAL pgcm(ilon, ilev)
43			REAL qgcm(ilon, ilev)
44			REAL pres(klevstd)
45			REAL qpres(ilon, klevstd)
46
47			! local :
48			! -------
49
50			! ym INTEGER lt(klon), lb(klon)
51			! ym REAL ptop, pbot, aist(klon), aisb(klon)
52
53			! ym save lt,lb,ptop,pbot,aist,aisb
54			INTEGER, ALLOCATABLE, SAVE, DIMENSION (:, :) :: lt, lb
55			REAL, ALLOCATABLE, SAVE, DIMENSION (:, :) :: aist, aisb
56			!$OMP THREADPRIVATE(lt,lb,aist,aisb)
57			REAL, SAVE :: ptop, pbot
58			!$OMP THREADPRIVATE(ptop, pbot)
59			LOGICAL, SAVE :: first = .TRUE.
60			INTEGER :: nlev
61			!$OMP THREADPRIVATE(first)
62			INTEGER i, k
63
64			! REAL missing_val
65			#ifndef CPP_XIOS
66			REAL :: missing_val
67			#endif
68
69			! missing_val = nf90_fill_real
70
71			#ifndef CPP_XIOS
72			missing_val=missing_val_nf90
73			#endif
74
75	✓✓	4896	IF (first) THEN
76	✓✗✗✓ ✗✓✗✓ ✗✓	1	ALLOCATE (lt(klon,klevstd), lb(klon,klevstd))
77	✓✗✓✗ ✗✓✗✓ ✗✓✓✗ ✗✓✗✓ ✗✓	3	ALLOCATE (aist(klon,klevstd), aisb(klon,klevstd))
78		1	first = .FALSE.
79			END IF
80
81			! =====================================================================
82	✓✓	4896	IF (lnew) THEN
83			! on reinitialise les reindicages et les poids
84			! =====================================================================
85
86
87			! Chercher les 2 couches les plus proches du niveau a obtenir
88
89			! Eventuellement, faire l'extrapolation a partir des deux couches
90			! les plus basses ou les deux couches les plus hautes:
91
92
93	✓✓	10368	DO nlev = 1, klevstd
94	✓✓	9743040	DO i = 1, klon
95	✓✓	9743040	IF (abs(pres(nlev)-pgcm(i,ilev))<abs(pres(nlev)-pgcm(i,1))) THEN
96		6554167	lt(i, nlev) = ilev ! 2
97		6554167	lb(i, nlev) = ilev - 1 ! 1
98			ELSE
99		3179081	lt(i, nlev) = 2
100		3179081	lb(i, nlev) = 1
101			END IF
102			END DO
103	✓✓	381888	DO k = 1, ilev - 1
104	✓✓	370245312	DO i = 1, klon
105		369863424	pbot = pgcm(i, k)
106		369863424	ptop = pgcm(i, k+1)
107	✓✓✓✓	370235520	IF (ptop<=pres(nlev) .AND. pbot>=pres(nlev)) THEN
108		9301637	lt(i, nlev) = k + 1
109		9301637	lb(i, nlev) = k
110			END IF
111			END DO
112			END DO
113
114			! Interpolation lineaire:
115	✓✓	9743616	DO i = 1, klon
116			! interpolation en logarithme de pression:
117
118			! ... Modif . P. Le Van ( 20/01/98) ....
119			! Modif Frederic Hourdin (3/01/02)
120
121			aist(i, nlev) = log(pgcm(i,lb(i,nlev))/pres(nlev))/log(pgcm(i,lb(i, &
122		9733248	nlev))/pgcm(i,lt(i,nlev)))
123			aisb(i, nlev) = log(pres(nlev)/pgcm(i,lt(i,nlev)))/log(pgcm(i,lb(i, &
124		9743040	nlev))/pgcm(i,lt(i,nlev)))
125			END DO
126			END DO
127
128			END IF ! lnew
129
130			! ======================================================================
131			! inteprollation
132			! ET je mets les vents a zero quand je rencontre une montagne
133			! ======================================================================
134
135	✓✓	88128	DO nlev = 1, klevstd
136	✓✓	82820736	DO i = 1, klon
137	✓✓	82815840	IF (pgcm(i,1)<pres(nlev)) THEN
138		3797206	qpres(i, nlev) = missing_val
139			ELSE
140			qpres(i, nlev) = qgcm(i, lb(i,nlev))*aisb(i, nlev) + &
141		78935402	qgcm(i, lt(i,nlev))*aist(i, nlev)
142			END IF
143			END DO
144			END DO
145
146
147		4896	RETURN
148			END SUBROUTINE plevel_new