1C Copyright 1981-2016 ECMWF.
2C
3C This software is licensed under the terms of the Apache Licence
4C Version 2.0 which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
5C
6C In applying this licence, ECMWF does not waive the privileges and immunities
7C granted to it by virtue of its status as an intergovernmental organisation
8C nor does it submit to any jurisdiction.
9C
10
11      PROGRAM gg_latitudes
12C
13C---->
14C**** gg_latitudes
15C
16C     Purpose
17C     -------
18C
19C     Command-line interface to JGETGG (interpolation).
20C
21C
22C     Externals
23C     ---------
24C
25C     JGETGG - Reads the definition of a gaussian grid.
26C
27C----<
28C
29
30C     Declarations
31      IMPLICIT NONE
32      INTEGER IARGC
33
34      ! local variables
35      INTEGER I, J
36      CHARACTER*5 ARG, GRID
37
38      ! global variables (all this to get to NGSPEC)
39      INTEGER
40     X  NILOCAL, NISTREM, NGSPEC ,
41     X  NIFORM , NIREPR , NIGRID , NIAREA , NIGAUSS, NIRESO ,
42     X  NIWE   , NINS   , NISCNM , NIPARAM, NITABLE, NIACC  ,
43     X  NJDCDOT, NIPCNT , NILEVEL, NILEVT , NIDATE , NICOMP ,
44     X  NISLSCP, NIPOGRS, NIPNGRS, NIMATR
45      REAL RISTRET, RMISSGV
46      DIMENSION NIGRID(2)
47      DIMENSION NIAREA(4)
48      COMMON /JDNIFLD/
49     X  RISTRET, RMISSGV,
50     X  NILOCAL, NISTREM, NGSPEC ,
51     X  NIFORM , NIREPR , NIGAUSS, NIRESO ,
52     X  NIWE   , NINS   , NISCNM , NIPARAM, NITABLE, NIACC  ,
53     X  NJDCDOT, NIPCNT , NILEVEL, NILEVT , NIDATE , NICOMP ,
54     X  NISLSCP, NIPOGRS, NIPNGRS, NIGRID , NIAREA , NIMATR
55      SAVE /JDNIFLD/
56
57      ! JGETGG arguments
58      INTEGER KNUM, KRET
59      CHARACTER*1 HTYPE
60      INTEGER KPTS(4000) ! (in parim.h, JPLAT = 4000)
61      REAL    PLAT(4000) ! ...
62
63
64C     Check arguments count
65      IF (IARGC() < 1) THEN
66          PRINT *,
67     X'Usage -- gg_latitudes [|-12] [[N|O|F]KNUM] ...'
68          PRINT *, '  -12     -- force RGG specification (NGSPEC=12)'
69          PRINT *, '  [N|O|F] -- Gaussian grid type(s)'
70          PRINT *, '             N: "quasi-regular" (default)'
71          PRINT *, '             O: octahedral'
72          PRINT *, '             F: non-reduced'
73          PRINT *, '  KNUM    -- Gaussian grid number(s), up to 2000'
74          STOP
75      END IF
76
77
78C     Process arguments in order
79      NGSPEC = 0
80      DO J = 1, IARGC()
81          CALL GETARG(J,ARG)
82          IF (ARG=='-12') THEN
83
84C             Force RGG specification
85              NGSPEC = 12
86
87          ELSE IF (ARG(1:1).NE.'N' .AND.
88     X             ARG(1:1).NE.'O' .AND.
89     X             ARG(1:1).NE.'F') THEN
90
91C             Gaussian grid type has to be specified
92              PRINT *,'Error: ARG="',ARG,'", ARG(1:1)!="[N|O|F]"'
93              CALL EXIT(-1)
94
95          ELSE
96
97C             Set Gaussian grid type (HTYPE) & number (KNUM)
98C             (read ([NOF])([0-9]{4}), HTYPE=$1, KNUM=$2)
99              KNUM = 0
100              READ (ARG,'(A1,I4)') HTYPE, KNUM
101              IF (HTYPE=='N') HTYPE = 'R'
102              IF (KNUM.GT.2000) THEN
103                  PRINT *,'Error: ARG="',ARG,'" KNUM>2000'
104                  CALL EXIT(-1)
105              END IF
106
107C             Call JGETGG
108              KPTS = 0
109              PLAT = 0.
110              CALL JGETGG(KNUM,HTYPE,PLAT,KPTS,KRET)
111              IF (KRET.NE.0) THEN
112                  PRINT *,'Error: ARG="',ARG,'" JGETGG KRET=',KRET
113                  CALL EXIT(KRET)
114              END IF
115
116C             Output
11776            FORMAT(8X,A5,8X,A4,8X,A12)
11877            FORMAT(8X,I5,8X,I4,8X,F12.5)
119              IF (HTYPE.EQ.'R') WRITE(GRID,'(A,I0)') 'N',   KNUM
120              IF (HTYPE.NE.'R') WRITE(GRID,'(A,I0)') HTYPE, KNUM
121              WRITE(*,76) GRID,    'KPTS',  'PLAT        '
122              WRITE(*,76) '-----', '----',  '------------'
123              DO I = 1, KNUM*2
124              WRITE(*,77) I,       KPTS(I), PLAT(I)
125              END DO
126
127          END IF
128      END DO
129
130      END PROGRAM
131
132