source: LMDZ5/trunk/libf/phylmd/hgardfou.F90 @ 2051

Last change on this file since 2051 was 1992, checked in by lguez, 10 years ago

Converted to free source form files in libf/phylmd which were still in
fixed source form. The conversion was done using the polish mode of
the NAG Fortran Compiler.

In addition to converting to free source form, the processing of the
files also:

-- indented the code (including comments);

-- set Fortran keywords to uppercase, and set all other identifiers
to lower case;

-- added qualifiers to end statements (for example "end subroutine
conflx", instead of "end");

-- changed the terminating statements of all DO loops so that each
loop ends with an ENDDO statement (instead of a labeled continue).

-- replaced #include by include.

  • Property copyright set to
    Name of program: LMDZ
    Creation date: 1984
    Version: LMDZ5
    License: CeCILL version 2
    Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
    See the license file in the root directory
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 3.2 KB
Line 
1
2! $Id: hgardfou.F90 1992 2014-03-05 13:19:12Z musat $
3SUBROUTINE hgardfou(t, tsol, text)
4  USE dimphy
5  USE phys_state_var_mod
6  USE indice_sol_mod
7  IMPLICIT NONE
8  ! ======================================================================
9  ! Verifier la temperature
10  ! ======================================================================
11  include "dimensions.h"
12  include "YOMCST.h"
13  include "iniprint.h"
14  REAL t(klon, klev), tsol(klon, nbsrf)
15  CHARACTER *(*) text
16  CHARACTER (LEN=20) :: modname = 'hgardfou'
17  CHARACTER (LEN=80) :: abort_message
18
19  INTEGER i, k, nsrf
20  REAL zt(klon)
21  INTEGER jadrs(klon), jbad
22  LOGICAL ok
23
24  LOGICAL firstcall
25  SAVE firstcall
26  DATA firstcall/.TRUE./
27  !$OMP THREADPRIVATE(firstcall)
28
29  IF (firstcall) THEN
30    WRITE (lunout, *) 'hgardfou garantit la temperature dans [100,370] K'
31    firstcall = .FALSE.
32    ! DO i = 1, klon
33    ! WRITE(lunout,*)'i=',i,'rlon=',rlon(i),'rlat=',rlat(i)
34    ! ENDDO
35
36  END IF
37
38  ok = .TRUE.
39  DO k = 1, klev
40    DO i = 1, klon
41      zt(i) = t(i, k)
42    END DO
43#ifdef CRAY
44    CALL whenfgt(klon, zt, 1, 370.0, jadrs, jbad)
45#else
46    jbad = 0
47    DO i = 1, klon
48      IF (zt(i)>370.) THEN
49        jbad = jbad + 1
50        jadrs(jbad) = i
51      END IF
52    END DO
53#endif
54    IF (jbad>0) THEN
55      ok = .FALSE.
56      DO i = 1, jbad
57        WRITE (lunout, *) 'i,k,temperature,lon,lat,pourc ter,lic,oce,sic =', &
58          jadrs(i), k, zt(jadrs(i)), rlon(jadrs(i)), rlat(jadrs(i)), &
59          (pctsrf(jadrs(i),nsrf), nsrf=1, nbsrf)
60      END DO
61    END IF
62#ifdef CRAY
63    CALL whenflt(klon, zt, 1, 100.0, jadrs, jbad)
64#else
65    jbad = 0
66    DO i = 1, klon
67      ! IF (zt(i).LT.100.0) THEN
68      IF (zt(i)<50.0) THEN
69        jbad = jbad + 1
70        jadrs(jbad) = i
71      END IF
72    END DO
73#endif
74    IF (jbad>0) THEN
75      ok = .FALSE.
76      DO i = 1, jbad
77        WRITE (lunout, *) 'i,k,temperature,lon,lat,pourc ter,lic,oce,sic =', &
78          jadrs(i), k, zt(jadrs(i)), rlon(jadrs(i)), rlat(jadrs(i)), &
79          (pctsrf(jadrs(i),nsrf), nsrf=1, nbsrf)
80      END DO
81    END IF
82  END DO
83
84  DO nsrf = 1, nbsrf
85    DO i = 1, klon
86      zt(i) = tsol(i, nsrf)
87    END DO
88#ifdef CRAY
89    CALL whenfgt(klon, zt, 1, 370.0, jadrs, jbad)
90#else
91    jbad = 0
92    DO i = 1, klon
93      IF (zt(i)>370.0) THEN
94        jbad = jbad + 1
95        jadrs(jbad) = i
96      END IF
97    END DO
98#endif
99    IF (jbad>0) THEN
100      ok = .FALSE.
101      DO i = 1, jbad
102        WRITE (lunout, *) &
103          'i,nsrf,temperature,lon,lat,pourc ter,lic,oce,sic =', jadrs(i), &
104          nsrf, zt(jadrs(i)), rlon(jadrs(i)), rlat(jadrs(i)), &
105          pctsrf(jadrs(i), nsrf)
106      END DO
107    END IF
108#ifdef CRAY
109    CALL whenflt(klon, zt, 1, 100.0, jadrs, jbad)
110#else
111    jbad = 0
112    DO i = 1, klon
113      ! IF (zt(i).LT.100.0) THEN
114      IF (zt(i)<50.0) THEN
115        jbad = jbad + 1
116        jadrs(jbad) = i
117      END IF
118    END DO
119#endif
120    IF (jbad>0) THEN
121      ok = .FALSE.
122      DO i = 1, jbad
123        WRITE (lunout, *) &
124          'i,nsrf,temperature,lon,lat,pourc ter,lic,oce,sic =', jadrs(i), &
125          nsrf, zt(jadrs(i)), rlon(jadrs(i)), rlat(jadrs(i)), &
126          pctsrf(jadrs(i), nsrf)
127      END DO
128    END IF
129  END DO
130
131  IF (.NOT. ok) THEN
132    abort_message = 'hgardfou s arrete ' // text
133    CALL abort_gcm(modname, abort_message, 1)
134  END IF
135
136  RETURN
137END SUBROUTINE hgardfou
Note: See TracBrowser for help on using the repository browser.