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 SUBROUTINE SH2SH(UFLDIN, KRESIN, UFLDOU, KRESOU) 12 IMPLICIT NONE 13C 14C----> 15C**** SH2SH 16C 17C Purpose 18C _______ 19C 20C This routine produces a field of spectral coefficients in UFLDOU 21C of truncation KRESOU from a field of spectral coeeficients in 22C UFLDIN of truncation KRESIN. 23C 24C 25C Interface 26C _________ 27C 28C CALL SH2SH(UFLDIN, KRESIN, UFLDOU, KRESOU) 29C 30C 31C Input parameters 32C ________________ 33C 34C UFLDIN - field of spectral coefficients 35C KRESIN - truncation of input field 36C KRESOU - truncation of output field 37C 38C 39C Output parameters 40C ________________ 41C 42C UFLDOU - field of spectral coefficients 43C 44C 45C Common block usage 46C __________________ 47C 48C None 49C 50C 51C Method 52C ______ 53C 54C If the input truncation is greater than (or equal to) the output 55C truncation, coefficients are transferred reduced for the output. 56C 57C If the input truncation is less than the output truncation, 58C all coefficients are transferred and padded with zeroes for the 59C output. 60C 61C 62C Externals 63C _________ 64C 65C None 66C 67C 68C Reference 69C _________ 70C 71C None 72C 73C 74C Comments 75C ________ 76C 77C Arrays for the input and output fields must be defined large 78C enough for the coefficients implied by the truncations. Thus 79C the dimension for UFLDOU must be at least: 80C ( KRESOU + 1) * ( KRESOU + 2 ) /2 81C 82C 83C Author 84C ______ 85C 86C J.D.Chambers ECMWF 8th Nov 1993 87C 88C 89C Modifications 90C _____________ 91C 92C None 93C 94C----< 95C _______________________________________________________ 96C 97C 98C* Section 0. Definition of variables. 99C _______________________________________________________ 100C 101C* Prefix conventions for variable names 102C 103C Logical L (but not LP), global or common. 104C O, dummy argument 105C G, local variable 106C LP, parameter. 107C Character C, global or common. 108C H, dummy argument 109C Y (but not YP), local variable 110C YP, parameter. 111C Integer M and N, global or common. 112C K, dummy argument 113C I, local variable 114C J (but not JP), loop control 115C JP, parameter. 116C Real A to F and Q to X, global or common. 117C P (but not PP), dummy argument 118C Z, local variable 119C PP, parameter. 120C Complex U, dummy argument 121C 122C _______________________________________________________ 123C 124C Subroutine arguments 125 COMPLEX UFLDIN(*),UFLDOU(*) 126 INTEGER KRESIN, KRESOU 127C 128C Local variables 129 INTEGER ITINP1, ITOUP1, ILIM, IMLIM, IMN, IMP, IADD 130 INTEGER JM, JN 131C 132C _______________________________________________________ 133C 134C 135C* Section 1. Initialization 136C _______________________________________________________ 137C 138 100 CONTINUE 139C 140C Initialize loop control variables 141C 142 ITINP1 = KRESIN + 1 143 ITOUP1 = KRESOU + 1 144 ILIM = ITOUP1 145 IMLIM = ITOUP1 146 IMN = 1 147 IMP = 1 148C 149C _______________________________________________________ 150C 151C 152C* Section 2. Computation. 153C _______________________________________________________ 154C 155 200 CONTINUE 156C 157C Check if desired output truncation greater than input ... 158C 159 IADD = KRESIN - KRESOU 160 IF ( IADD .GE. 0 ) THEN 161C 162C ... input truncation not less than desired output ... 163C ... move truncated lines of coefficients 164 DO 230 JM = 1, IMLIM 165 DO 220 JN = JM, ILIM 166 UFLDOU(IMP) = UFLDIN(IMN) 167 IMP = IMP + 1 168 IMN = IMN + 1 169220 CONTINUE 170C Skip coefficients being truncated 171 IMN = IMN + IADD 172230 CONTINUE 173C 174C ... input truncation is less than desired output ... 175C ... pad each output line of coefficients with zeroes 176 ELSE 177 DO 250 JM = 1, IMLIM 178 DO 240 JN = JM, ILIM 179 IF ( JN .GT. ITINP1 .OR. JM .GT. ITINP1) THEN 180C At end of input coefficients in 181C current row, then set values to 182C zero in output 183 UFLDOU(IMP) = 0.0 184 ELSE 185 UFLDOU(IMP) = UFLDIN(IMN) 186 IMN = IMN + 1 187 ENDIF 188 IMP = IMP + 1 189240 CONTINUE 190250 CONTINUE 191 ENDIF 192C 193C _______________________________________________________ 194C 195C 196C* Section 9. Return to calling routine. 197C _______________________________________________________ 198C 199 900 CONTINUE 200 RETURN 201 END 202