*IF DEF,C84_1A EXTTS1A.2
C ******************************COPYRIGHT****************************** GTS2F400.2719
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.2720
C GTS2F400.2721
C Use, duplication or disclosure of this code is subject to the GTS2F400.2722
C restrictions as set forth in the contract. GTS2F400.2723
C GTS2F400.2724
C Meteorological Office GTS2F400.2725
C London Road GTS2F400.2726
C BRACKNELL GTS2F400.2727
C Berkshire UK GTS2F400.2728
C RG12 2SZ GTS2F400.2729
C GTS2F400.2730
C If no contract has been raised with this copy of the code, the use, GTS2F400.2731
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.2732
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.2733
C Modelling at the above address. GTS2F400.2734
C ******************************COPYRIGHT****************************** GTS2F400.2735
C GTS2F400.2736
CLL ----------------------------------------------------------- EXTTS1A.3
CLL Stash routine EXTTS1A.4
CLL purpose: Generate extra data for the timeseries. EXTTS1A.5
CLL This extra data provides information about what processing was done EXTTS1A.6
CLL to produce the timeseries. This information will hopefully be of som EXTTS1A.7
CLL use to users doing further processing of the timeseries data. EXTTS1A.8
CLL This deck contains two subroutines EXTTS1A.9
CLL (1) EXTRA_TS_INFO : which generates the codes and sets up the space EXTTS1A.10
CLL : for the extra data. EXTTS1A.11
CLL EXTTS1A.12
CLL (2) EXTRA_MAKE_VECTOR: which computes the long/latt ht domain info EXTTS1A.13
CLL : and puts that into the correct place in the EXTTS1A.14
CLL : extra data EXTTS1A.15
CLL Routines are called by stmulspa1. EXTTS1A.16
CLL EXTTS1A.17
CLL To some extent this routine has much in common with the EXTTS1A.18
CLL multi_spatial routine but as it has a different function EXTTS1A.19
CLL viz generate info on timeseries rather than generating a single time EXTTS1A.20
CLL for the timeseries it is coded separately. EXTTS1A.21
CLL when modifying multi_spatial be sure also to modify this routine and EXTTS1A.22
CLL vice versa EXTTS1A.23
CLL EXTTS1A.24
CLL 16/3/92 Written by Simon Tett EXTTS1A.25
CLL EXTTS1A.26
CLL Model Modification history from model version 3.0: EXTTS1A.27
CLL version date EXTTS1A.28
CLL EXTTS1A.29
CLL Programming Standard: UM DOC Paper3, Verion 4 (05/02/92) EXTTS1A.30
CLL EXTTS1A.31
CLL System Component Covered: D711 EXTTS1A.32
CLL EXTTS1A.33
CLL System Task:C4 EXTTS1A.34
CLL EXTTS1A.35
EXTTS1A.36
C*L Interface and arguments ------------------------------------ EXTTS1A.37
C EXTTS1A.38
SUBROUTINE EXTRA_TS_INFO(extra_data,extra_data_len,no_records) 1,1EXTTS1A.39
implicit none EXTTS1A.40
EXTTS1A.41
integer no_records ! IN how many timeseries records are there ? EXTTS1A.42
integer extra_data_len ! IN size of extra data required EXTTS1A.43
real extra_data(extra_data_len) ! OUT the extra data array EXTTS1A.44
C*L LOCAL PARAMETERS EXTTS1A.45
CLL -------------------------------------------------------------------- EXTTS1A.46
integer no_extra_blocks ! how many blocks of extra data we got ? EXTTS1A.47
parameter(no_extra_blocks=6) ! 6 words to describe EXTTS1A.48
C*L Subroutines called EXTTS1A.49
EXTERNAL stuff_int ! put an integer into a real EXTTS1A.50
C*L Local variables EXTTS1A.51
CLL ------------------------------------------------- EXTTS1A.52
integer record_len ! size of block for extra data EXTTS1A.53
integer hdr(no_extra_blocks) ! the headers for each block EXTTS1A.54
C order is lat, long, 2nd lat, 2nd long, first level, 2nd level EXTTS1A.55
data hdr/3,4,5,6,7,8/ ! codes for above EXTTS1A.56
integer addr ! address in array for writting/reading data EXTTS1A.57
integer i ! loop count EXTTS1A.58
EXTTS1A.59
CL------------------------------------------------------------------- EXTTS1A.60
record_len=no_records+1 ! how much info in a block EXTTS1A.61
addr=1 EXTTS1A.62
DO i=1,no_extra_blocks ! put the headers into the extra data EXTTS1A.63
CALL STUFF_INT
(extra_data(addr), EXTTS1A.64
& 1000*no_records+hdr(i)) EXTTS1A.65
addr=addr+record_len EXTTS1A.66
ENDDO EXTTS1A.67
RETURN EXTTS1A.68
END EXTTS1A.69
EXTTS1A.70
EXTTS1A.71
C*L Interface and arguments: ----------------------------- EXTTS1A.72
SUBROUTINE EXTRA_MAKE_VECTOR(control,control_len,record_cnt, 1EXTTS1A.73
& no_records,extra_data,extra_data_len, EXTTS1A.74
& bzx,bzy,bdx,bdy) EXTTS1A.75
implicit none EXTTS1A.76
integer control_len ! IN size of control record EXTTS1A.77
integer control(control_len) ! IN stash control record EXTTS1A.78
integer record_cnt ! IN record that is being processed EXTTS1A.79
integer no_records ! IN total number of records EXTTS1A.80
integer extra_data_len ! IN size of extra data EXTTS1A.81
real extra_data(extra_data_len) !IN/OUT extra data EXTTS1A.82
real bdx,bdy,bzx,bzy ! IN grid descriptors EXTTS1A.83
C* ------------------------------------------------------ EXTTS1A.84
C Parameters EXTTS1A.85
C EXTTS1A.86
*CALL STPARAM EXTTS1A.87
*CALL STERR EXTTS1A.88
C*L EXTTS1A.89
C Subroutines called: none EXTTS1A.90
C EXTTS1A.91
C*L Local variables EXTTS1A.92
integer addr ! what address in extra data are we at EXTTS1A.93
integer record_len ! how many words in a block ? EXTTS1A.94
C*L EXTTS1A.95
record_len=no_records+1 EXTTS1A.96
addr=1+record_cnt EXTTS1A.97
CL put in the first latitude EXTTS1A.98
extra_data(addr)=control(st_south_code)*bdy+bzy EXTTS1A.99
addr=addr+record_len EXTTS1A.100
CL put in the first long EXTTS1A.101
extra_data(addr)=control(st_west_code)*bdx+bzx EXTTS1A.102
addr=addr+record_len EXTTS1A.103
CL put in the second lat EXTTS1A.104
extra_data(addr)=control(st_north_code)*bdy+bzy EXTTS1A.105
addr=addr+record_len EXTTS1A.106
CL put in the second long EXTTS1A.107
extra_data(addr)=control(st_east_code)*bdx+bzx EXTTS1A.108
addr=addr+record_len EXTTS1A.109
CL put in the lowest level EXTTS1A.110
extra_data(addr)=control(st_input_bottom) EXTTS1A.111
addr=addr+record_len EXTTS1A.112
CL and now the highest level EXTTS1A.113
extra_data(addr)=control(st_input_top) EXTTS1A.114
EXTTS1A.115
RETURN EXTTS1A.116
END EXTTS1A.117
EXTTS1A.118
EXTTS1A.119
SUBROUTINE STUFF_INT(array_out,data_in) 1EXTTS1A.120
CL routine to put an integer (or other single word) into a real variable EXTTS1A.121
CL through hidden equivalencing via argument passing EXTTS1A.122
real array_out EXTTS1A.123
real data_in EXTTS1A.124
array_out=data_in EXTTS1A.125
RETURN EXTTS1A.126
END EXTTS1A.127
*ENDIF EXTTS1A.128