*IF DEF,C84_1A EXPTENC1.2
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.15048
C GTS2F400.15049
C Use, duplication or disclosure of this code is subject to the GTS2F400.15050
C restrictions as set forth in the contract. GTS2F400.15051
C GTS2F400.15052
C Meteorological Office GTS2F400.15053
C London Road GTS2F400.15054
C BRACKNELL GTS2F400.15055
C Berkshire UK GTS2F400.15056
C RG12 2SZ GTS2F400.15057
C GTS2F400.15058
C If no contract has been raised with this copy of the code, the use, GTS2F400.15059
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.15060
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.15061
C Modelling at the above address. GTS2F400.15062
C ******************************COPYRIGHT****************************** GTS2F400.15063
C GTS2F400.15064
CLL SUBROUTINE EXPT_ENC-------------------------------------------- EXPTENC1.3
CLL EXPTENC1.4
CLL Given a valid five character experiment RUN_ID, an INTEGER*4 EXPTENC1.5
CLL code number is generated. The valid experiment name characters EXPTENC1.6
CLL are A-Z (uppercase), 0-9. Each letter of the experiment name is EXPTENC1.7
CLL stored as a 6 bit number. The last letter is converted to the EXPTENC1.8
CLL 6 least significant bits of the integer code, the next letter EXPTENC1.9
CLL the next 6 lsb's, etc. Hence 30 bits are used in all. EXPTENC1.10
CLL The lookup table is capable of holding 64 elements. This EXPTENC1.11
CLL number cannot be exceeded if the code number is to remain EXPTENC1.12
CLL INTEGER*4. Similarly, the experiment RUN_ID length (5 chars) EXPTENC1.13
CLL cannot be exceeded. EXPTENC1.14
CLL Subroutine called from PP_HEAD. EXPTENC1.15
CLL EXPTENC1.16
CLL A. Brady <- programmer of some or all of previous code or changes EXPTENC1.17
CLL EXPTENC1.18
CLL Model Modification history from model version 3.0: EXPTENC1.19
CLL version Date EXPTENC1.20
CLL EXPTENC1.21
CLL Programming standard: EXPTENC1.22
CLL EXPTENC1.23
CLL Logical components covered: EXPTENC1.24
CLL EXPTENC1.25
CLL Project TASK: EXPTENC1.26
CLL EXPTENC1.27
CLL External documentation: EXPTENC1.28
CLL EXPTENC1.29
CLLEND------------------------------------------------------------- EXPTENC1.30
EXPTENC1.31
C*L INTERFACE and ARGUMENTS:-------------------------------------- EXPTENC1.32
EXPTENC1.33
SUBROUTINE EXPT_ENC(EXPTSTRG 1EXPTENC1.34
& ,EXPTCODE EXPTENC1.35
& ,ICODE EXPTENC1.36
& ,CMESSAGE) EXPTENC1.37
C*----------------------------------------------------------------- EXPTENC1.38
EXPTENC1.39
IMPLICIT NONE EXPTENC1.40
EXPTENC1.41
INTEGER ICODE !OUT Return code: successful=0 EXPTENC1.42
CHARACTER*80 CMESSAGE !OUT Error message if ICODE > 0 EXPTENC1.43
EXPTENC1.44
CHARACTER*5 EXPTSTRG !IN Experiment name string. Length EXPTENC1.45
! must equal parameter STRSIZE EXPTENC1.46
INTEGER EXPTCODE !OUT Experiment code integer EXPTENC1.47
EXPTENC1.48
C Define local variables EXPTENC1.49
EXPTENC1.50
LOGICAL TEST EXPTENC1.51
CHARACTER*1 LETTER EXPTENC1.52
INTEGER I,J,NEWNUM,LETNUM,NSTRINGS,NBITS,STRSIZE EXPTENC1.53
EXPTENC1.54
PARAMETER(NSTRINGS=36, EXPTENC1.55
& NBITS=6, EXPTENC1.56
& STRSIZE=5) EXPTENC1.57
EXPTENC1.58
CHARACTER*1 USTRINGS ! Upper case strings EXPTENC1.59
CHARACTER*1 LSTRINGS ! Lower case strings EXPTENC1.60
EXPTENC1.61
DIMENSION USTRINGS(0:NSTRINGS-1) EXPTENC1.62
DIMENSION LSTRINGS(0:NSTRINGS-1) EXPTENC1.63
EXPTENC1.64
DATA USTRINGS/'A','B','C','D','E','F','G','H','I','J', EXPTENC1.65
& 'K','L','M','N','O','P','Q','R','S','T', EXPTENC1.66
& 'U','V','W','X','Y','Z','0','1','2','3', EXPTENC1.67
& '4','5','6','7','8','9'/ EXPTENC1.68
EXPTENC1.69
DATA LSTRINGS/'a','b','c','d','e','f','g','h','i','j', EXPTENC1.70
& 'k','l','m','n','o','p','q','r','s','t', EXPTENC1.71
& 'u','v','w','x','y','z','0','1','2','3', EXPTENC1.72
& '4','5','6','7','8','9'/ EXPTENC1.73
EXPTENC1.74
C Begin main EXPTENC1.75
EXPTENC1.76
EXPTCODE=0 EXPTENC1.77
LETNUM=STRSIZE EXPTENC1.78
EXPTENC1.79
C Loop over letters in EXPTSTRG EXPTENC1.80
DO 20 I=0,STRSIZE-1 EXPTENC1.81
TEST=.FALSE. EXPTENC1.82
READ(EXPTSTRG(LETNUM:LETNUM),"(A1)")LETTER EXPTENC1.83
EXPTENC1.84
C Loop over letters in lookup table USTRINGS/LSTRINGS EXPTENC1.85
DO 10 J=0,NSTRINGS-1 EXPTENC1.86
IF ((LETTER.EQ.USTRINGS(J)).OR.(LETTER.EQ.LSTRINGS(J))) THEN EXPTENC1.87
TEST=.TRUE. EXPTENC1.88
NEWNUM=J*(2**(I*NBITS)) EXPTENC1.89
EXPTCODE=EXPTCODE+NEWNUM EXPTENC1.90
C Exit loop as we have found the code for this letter EXPTENC1.91
GOTO 15 EXPTENC1.92
ENDIF EXPTENC1.93
10 CONTINUE EXPTENC1.94
15 CONTINUE EXPTENC1.95
EXPTENC1.96
C Check experiment name is valid EXPTENC1.97
IF (.NOT.TEST) THEN EXPTENC1.98
ICODE=99 EXPTENC1.99
CMESSAGE='EXPT_ENC: Invalid letter in expt name (RUN_ID)' EXPTENC1.100
RETURN EXPTENC1.101
ENDIF EXPTENC1.102
LETNUM=LETNUM-1 EXPTENC1.103
20 CONTINUE EXPTENC1.104
EXPTENC1.105
RETURN EXPTENC1.106
END EXPTENC1.107
*ENDIF EXPTENC1.108