1 /* -- translated by f2c (version 20100827).
2 You must link the resulting object file with libf2c:
3 on Microsoft Windows system, link with libf2c.lib;
4 on Linux or Unix systems, link with .../path/to/libf2c.a -lm
5 or, if you install libf2c.a in a standard place, with -lf2c -lm
6 -- in that order, at the end of the command line, as in
7 cc *.o -lf2c -lm
8 Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
9
10 http://www.netlib.org/f2c/libf2c.zip
11 */
12
13 #include "libtinyf2c.h"
14
15 /* Common Block Declarations */
16
17 struct {
18 real tl1[100], tl2[100];
19 integer ipt[100], nt;
20 logical lascnd;
21 } ueblk1_;
22
23 #define ueblk1_1 ueblk1_
24
25 /* Table of constant values */
26
27 static integer c__2 = 2;
28 static integer c__1 = 1;
29 static logical c_false = FALSE_;
30
31 /* ----------------------------------------------------------------------- */
32 /* UEZCHK */
33 /* ----------------------------------------------------------------------- */
34 /* Copyright (C) 2000-2004 GFD Dennou Club. All rights reserved. */
35 /* ----------------------------------------------------------------------- */
uezchk_(real * z__,integer * mx,integer * nx,integer * ny,char * cname,integer * istat,ftnlen cname_len)36 /* Subroutine */ int uezchk_(real *z__, integer *mx, integer *nx, integer *ny,
37 char *cname, integer *istat, ftnlen cname_len)
38 {
39 /* System generated locals */
40 integer z_dim1, z_offset;
41 real r__1;
42
43 /* Builtin functions */
44 /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
45 integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void)
46 ;
47
48 /* Local variables */
49 static integer npx[2], nqx[2], nsx[2];
50 static char cmsg[80];
51 static integer ipat, nlev;
52 static logical lset;
53 static real rlev;
54 static logical lmada, ltone, lmiss;
55 extern real rvmin_(real *, integer *, integer *, integer *, integer *);
56 static real rmiss;
57 extern real rvmax_(real *, integer *, integer *, integer *, integer *);
58 static real rminz, rmaxz;
59 extern /* Subroutine */ int gllget_(char *, logical *, ftnlen), ueiget_(
60 char *, integer *, ftnlen), uegtlb_(real *, integer *, integer *,
61 integer *, real *), glrget_(char *, real *, ftnlen), uelget_(char
62 *, logical *, ftnlen), msgdmp_(char *, char *, char *, ftnlen,
63 ftnlen, ftnlen), uerget_(char *, real *, ftnlen), uestlv_(real *,
64 real *, integer *), ueqtlz_(logical *), uestlz_(logical *);
65
66 /* Fortran I/O blocks */
67 static icilist io___10 = { 0, cmsg+10, 0, "(1P,E10.3)", 10, 1 };
68
69
70 /* / GET INTERNAL PARAMETERS / */
71 /* Parameter adjustments */
72 z_dim1 = *mx;
73 z_offset = 1 + z_dim1;
74 z__ -= z_offset;
75
76 /* Function Body */
77 gllget_("LMISS ", &lmiss, (ftnlen)8);
78 glrget_("RMISS ", &rmiss, (ftnlen)8);
79 /* / CHECK MIN & MAX / */
80 nsx[0] = *mx;
81 nsx[1] = *ny;
82 npx[0] = 1;
83 npx[1] = 1;
84 nqx[0] = *nx;
85 nqx[1] = *ny;
86 rminz = rvmin_(&z__[z_offset], nsx, npx, nqx, &c__2);
87 rmaxz = rvmax_(&z__[z_offset], nsx, npx, nqx, &c__2);
88 lmada = lmiss && rminz == rmiss && rmaxz == rmiss;
89 *istat = 0;
90 if (lmada || rminz == rmaxz) {
91 /* / MESSAGE FOR MISSING OR CONSTANT FIELD / */
92 if (lmada) {
93 s_copy(cmsg, "MISSING FIELD.", (ftnlen)80, (ftnlen)14);
94 *istat = 1;
95 } else {
96 s_copy(cmsg, "CONSTANT (##########) FIELD.", (ftnlen)80, (ftnlen)
97 28);
98 s_wsfi(&io___10);
99 do_fio(&c__1, (char *)&rminz, (ftnlen)sizeof(real));
100 e_wsfi();
101 *istat = 2;
102 }
103 msgdmp_("W", cname, cmsg, (ftnlen)1, cname_len, (ftnlen)80);
104 }
105 /* / GENERATE TONE LEVELS IF THEY HAVE NOT BEEN GENERATED YET / */
106 ueqtlz_(&lset);
107 if (! lset) {
108 uelget_("LTONE", <one, (ftnlen)5);
109 if (ltone) {
110 ueiget_("NLEV", &nlev, (ftnlen)4);
111 r__1 = -((real) nlev);
112 uegtlb_(&z__[z_offset], mx, nx, ny, &r__1);
113 } else {
114 ueiget_("IPAT", &ipat, (ftnlen)4);
115 uerget_("RLEV", &rlev, (ftnlen)4);
116 uestlv_(&rmiss, &rlev, &ipat);
117 }
118 uestlz_(&c_false);
119 }
120 return 0;
121 } /* uezchk_ */
122
123