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 CREXSTDR(KJ,KJ1,KDD,KSTACK,KERR) 12C 13C**** *CREXSTDR* 14C 15C 16C PURPOSE. 17C -------- 18C Solve CREX table D reference. 19C 20C 21C** INTERFACE. 22C ---------- 23C 24C *CALL* *CREXSTDR(KJ,KJ1,KDD,KSTACK,KERR)* 25C 26C INPUT : 27C *KDD* - data descriptor 28C OUTPUT: 29C *KJ* - pointer to kstack array 30C *KJ1* - pointer to last element in kstack 31C *KSTACK* - list of data descriptors 32C *KERR* - return error code 33C 34C 35C METHOD. 36C ------- 37C 38C NONE. 39C 40C EXTERNALS. 41C ---------- 42C 43C NONE. 44C 45C REFERENCE. 46C ---------- 47C 48C NONE. 49C 50C AUTHOR. 51C ------- 52C 53C MILAN DRAGOSAVAC *ECMWF* 07/01/2004. 54C 55C 56C MODIFICATIONS. 57C -------------- 58C 59C NONE. 60C 61C 62 IMPLICIT LOGICAL(L,O,G), CHARACTER*8(C,H,Y) 63C 64C 65 PARAMETER(JSUP = 9,JSEC0= 3,JSEC1= 40,JSEC2= 64 ,JSEC3= 4, 66 1 JSEC4= 2,JELEM=40000,JSUBS=400,JCVAL=150 ,JBUFL=40000, 67 2 JBPW = 32,JTAB =3000,JCTAB=120,JCTST=1800,JCTEXT= 200, 68 3 JWORK=360000,JKEY=46) 69C 70C 71 COMMON/CREXTAB/ NCREXBR(JTAB),NCREXBS(JTAB) , NCREXBDW(JTAB), 72 1 NCREXDR(JTAB),NCREXDST(JTAB) , 73 2 NCREXDL(JTAB),NCREXDSQ(JTAB*20),NCREXP(64,255) 74 75C 76C NCREXBR - table B, table reference array 77C NCREXBS - table B, scale array 78C NCREXBDW - table B, data width array 79C NCREXDR - table D, table reference array 80C NCREXDST - table D, starting pointers array 81C NCREXDL - table D, lengths array 82C NCREXDSQ - table D, list of sequence descriptors array 83C 84 85 COMMON/CREXTABC/ CREXNAME(JTAB),CREXUNIT(JTAB),CREXLST(JELEM) 86C 87C CREXNAME - table B, ELEMENT NAME array 88C CREXUNIT - table B, unit array 89C 90C 91 character*64 CREXNAME 92 character*24 CREXUNIT 93 character*6 CREXLST 94C 95 DIMENSION ILIST(JELEM),KSTACK(*) 96C 97C ------------------------------------------------------------------ 98C 99C* 1. OBTAIN LIST OF DESCRIPTORS FROM CREX TABLE D. 100C --------------------------------------------- 101 100 CONTINUE 102C 103 IF( KERR.NE.0 ) RETURN 104C 105 DO 110 J=1,JTAB 106C 107 IF(KDD.EQ.NCREXDR(J)) THEN 108 I=J 109 GO TO 120 110 END IF 111C 112 110 CONTINUE 113C 114 KERR=20 115 PRINT*,' CREXSTDR :',KDD 116 CALL CREXERR(KERR) 117 RETURN 118C 119 120 CONTINUE 120C 121 J1=NCREXDST(I) 122 J2=NCREXDL (I) 123 J3=0 124C 125 DO 121 J=J1,J1+J2-1 126C 127 J3 = J3 +1 128 ILIST(J3) = NCREXDSQ(J) 129C 130 121 CONTINUE 131C 132C ------------------------------------------------------------------ 133C* 2. PUSH DOWN DATA DESCRIPTION DESCRIPTORS 134C -------------------------------------- 135C TO MAKE ROOM FOR LIST. 136C ---------------------- 137 200 CONTINUE 138C 139 J2M1=J2-1 140C 141 DO 210 J=KJ1,KJ+1,-1 142C 143 KSTACK(J+J2M1) = KSTACK(J) 144C 145 210 CONTINUE 146C 147C ------------------------------------------------------------------ 148C* 3. INSERT LIST IN PLACE OF SEQUENCE DESCRIPTORS. 149C --------------------------------------------- 150 300 CONTINUE 151C 152 KJM1=KJ-1 153C 154 DO 310 J=1,J3 155C 156 KSTACK(KJM1+J)= ILIST(J) 157C 158 310 CONTINUE 159C 160C ------------------------------------------------------------------ 161C* 4. ADJUST DESCRIPTOR COUNT FOR LIST LENGTH. 162C ---------------------------------------- 163 400 CONTINUE 164C 165 KJ = KJ - 1 166 KJ1 = KJ1 +J3 -1 167C ------------------------------------------------------------------ 168C* 4.1 ADJUST NUMBER OF DATA DESCRIPTORS NOT PRESENT. 169C ---------------------------------------------- 170 610 CONTINUE 171C 172C ----------------------------------------------------------------- 173 500 CONTINUE 174C 175 RETURN 176C 177 9901 FORMAT(1H ,' CREXSTDR : table D reference not found, error=',I2) 178C 179 END 180