[4f24798] | 1 | ! Copyright 1981-2016 ECMWF. |
---|
| 2 | ! |
---|
| 3 | ! This software is licensed under the terms of the Apache Licence |
---|
| 4 | ! Version 2.0 which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. |
---|
| 5 | ! |
---|
| 6 | ! In applying this licence, ECMWF does not waive the privileges and immunities |
---|
| 7 | ! granted to it by virtue of its status as an intergovernmental organisation |
---|
| 8 | ! nor does it submit to any jurisdiction. |
---|
| 9 | ! |
---|
| 10 | |
---|
| 11 | SUBROUTINE JSPPOLE(PSHUP,KNUMB,KTRUNC,OMARS,PXF) |
---|
| 12 | IMPLICIT NONE |
---|
| 13 | ! |
---|
| 14 | !----> |
---|
| 15 | !**** *JSPPOLE* - Calculates fourier coefficient for U or V at pole |
---|
| 16 | ! |
---|
| 17 | ! Purpose |
---|
| 18 | ! ------- |
---|
| 19 | ! |
---|
| 20 | ! Calculates fourier coefficient for first harmonic only |
---|
| 21 | ! for U and V wind component at the pole. |
---|
| 22 | ! |
---|
| 23 | ! Interface |
---|
| 24 | ! --------- |
---|
| 25 | ! |
---|
| 26 | ! CALL JSPPOLE(PSHUP,KNUMB,KTRUNC,OMARS,PXF) |
---|
| 27 | ! |
---|
| 28 | ! Input parameters |
---|
| 29 | ! ---------------- |
---|
| 30 | ! |
---|
| 31 | ! PSHUP - Unpacked harmonics field, unpacked |
---|
| 32 | ! KNUMB - 1 for North Pole, otherwise South Pole |
---|
| 33 | ! KTRUNC - Number (value) of the trucation |
---|
| 34 | ! OMARS - .TRUE. if data is from MARS |
---|
| 35 | ! PXF - Fourier coefficients (zero on input) |
---|
| 36 | ! |
---|
| 37 | ! |
---|
| 38 | ! Output parameters |
---|
| 39 | ! ----------------- |
---|
| 40 | ! |
---|
| 41 | ! PXF(2) - Single fourier coefficient calculated |
---|
| 42 | ! |
---|
| 43 | ! |
---|
| 44 | ! Common block usage |
---|
| 45 | ! ----------------- |
---|
| 46 | ! |
---|
| 47 | ! None. |
---|
| 48 | ! |
---|
| 49 | ! |
---|
| 50 | ! Externals |
---|
| 51 | ! --------- |
---|
| 52 | ! |
---|
| 53 | ! None. |
---|
| 54 | ! |
---|
| 55 | ! |
---|
| 56 | ! Author |
---|
| 57 | ! ------ |
---|
| 58 | ! |
---|
| 59 | ! J.D.Chambers *ECMWF* Oct 1993 |
---|
| 60 | ! |
---|
| 61 | ! |
---|
| 62 | ! Modifications |
---|
| 63 | ! ------------- |
---|
| 64 | ! |
---|
| 65 | ! None. |
---|
| 66 | ! |
---|
| 67 | ! |
---|
| 68 | ! Comments |
---|
| 69 | ! -------- |
---|
| 70 | ! |
---|
| 71 | ! Created from SPPOLE. |
---|
| 72 | ! Changed to provide all parameters in the call, i.e. no common |
---|
| 73 | ! blocks are used. |
---|
| 74 | ! |
---|
| 75 | ! |
---|
| 76 | ! Method |
---|
| 77 | ! ------ |
---|
| 78 | ! |
---|
| 79 | ! None. |
---|
| 80 | ! |
---|
| 81 | ! |
---|
| 82 | ! Reference |
---|
| 83 | ! _________ |
---|
| 84 | ! |
---|
| 85 | ! None. |
---|
| 86 | ! |
---|
| 87 | !----< |
---|
| 88 | ! _______________________________________________________ |
---|
| 89 | ! |
---|
| 90 | !* Section 0. Definition of variables. |
---|
| 91 | ! _______________________________________________________ |
---|
| 92 | ! |
---|
| 93 | !* Prefix conventions for variable names |
---|
| 94 | ! |
---|
| 95 | ! Logical L (but not LP), global or common. |
---|
| 96 | ! O, dummy argument |
---|
| 97 | ! G, local variable |
---|
| 98 | ! LP, parameter. |
---|
| 99 | ! Character C, global or common. |
---|
| 100 | ! H, dummy argument |
---|
| 101 | ! Y (but not YP), local variable |
---|
| 102 | ! YP, parameter. |
---|
| 103 | ! Integer M and N, global or common. |
---|
| 104 | ! K, dummy argument |
---|
| 105 | ! I, local variable |
---|
| 106 | ! J (but not JP), loop control |
---|
| 107 | ! JP, parameter. |
---|
| 108 | ! REAL A to F and Q to X, global or common. |
---|
| 109 | ! P (but not PP), dummy argument |
---|
| 110 | ! Z, local variable |
---|
| 111 | ! PP, parameter. |
---|
| 112 | ! |
---|
| 113 | ! Dummy arguments |
---|
| 114 | ! |
---|
| 115 | COMPLEX PSHUP |
---|
| 116 | INTEGER KNUMB |
---|
| 117 | INTEGER KTRUNC |
---|
| 118 | LOGICAL OMARS |
---|
| 119 | COMPLEX PXF |
---|
| 120 | DIMENSION PSHUP(*) |
---|
| 121 | DIMENSION PXF(*) |
---|
| 122 | ! |
---|
| 123 | ! Local variables |
---|
| 124 | ! |
---|
| 125 | INTEGER I1, ITIN1, ITOUT1, JN |
---|
| 126 | REAL Z1, Z2, ZNORM, ZP1, ZP2, ZPOL |
---|
| 127 | ! |
---|
| 128 | ! ----------------------------------------------------------- |
---|
| 129 | ! |
---|
| 130 | !* 1. Set initial values |
---|
| 131 | ! ------------------ |
---|
| 132 | ! |
---|
| 133 | 100 CONTINUE |
---|
| 134 | ! |
---|
| 135 | ITIN1 = KTRUNC + 1 |
---|
| 136 | ITOUT1 = KTRUNC |
---|
| 137 | ! |
---|
| 138 | ZPOL = 1. |
---|
| 139 | IF (KNUMB .NE. 1) ZPOL = -1.0 |
---|
| 140 | ! |
---|
| 141 | ZP1 = -1.0 |
---|
| 142 | ZP2 = -3.0 * ZPOL |
---|
| 143 | I1 = ITIN1 + 1 |
---|
| 144 | ! |
---|
| 145 | !* 2. Change normalisation (if flagged as necessary) |
---|
| 146 | ! -------------------- |
---|
| 147 | ! |
---|
| 148 | 200 CONTINUE |
---|
| 149 | ! |
---|
| 150 | IF (OMARS) THEN |
---|
| 151 | ZNORM = -SQRT(2.0) |
---|
| 152 | ELSE |
---|
| 153 | ZNORM = 1 |
---|
| 154 | ENDIF |
---|
| 155 | ! |
---|
| 156 | ! |
---|
| 157 | !* 3. Calculation |
---|
| 158 | ! ----------- |
---|
| 159 | ! |
---|
| 160 | 300 CONTINUE |
---|
| 161 | PXF(2) = (0.0,0.0) |
---|
| 162 | ! |
---|
| 163 | ! Calculate the fourier coefficient for the first harmonic only. |
---|
| 164 | DO 310 JN = 1,ITOUT1,2 |
---|
| 165 | ! |
---|
| 166 | Z1 = SQRT( (2.0*JN + 1.0)/(2.0*JN*(JN + 1.0)) ) |
---|
| 167 | Z2 = SQRT( (2.0*(JN + 1.0) +1.0)/(2.0*(JN +1.0)*(JN +2.0)) ) |
---|
| 168 | ! |
---|
| 169 | IF (JN .EQ. ITOUT1) Z2 = 0.0 |
---|
| 170 | ! |
---|
| 171 | PXF(2) = PXF(2) +(Z1*ZP1*PSHUP(I1) +Z2*ZP2*PSHUP(I1+1))*ZNORM |
---|
| 172 | ZP1 = ZP1 - 2.0*(JN + 1.0) - 1.0 |
---|
| 173 | ZP2 = ZP2 - (2.0*(JN + 2.0) + 1.0)*ZPOL |
---|
| 174 | I1 = I1 + 2 |
---|
| 175 | ! |
---|
| 176 | 310 CONTINUE |
---|
| 177 | ! |
---|
| 178 | ! ------------------------------------------------------------- |
---|
| 179 | ! |
---|
| 180 | RETURN |
---|
| 181 | ! |
---|
| 182 | END |
---|