*IF DEF,CONTROL TRANSIN1.2
C ******************************COPYRIGHT****************************** GTS2F400.10531
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.10532
C GTS2F400.10533
C Use, duplication or disclosure of this code is subject to the GTS2F400.10534
C restrictions as set forth in the contract. GTS2F400.10535
C GTS2F400.10536
C Meteorological Office GTS2F400.10537
C London Road GTS2F400.10538
C BRACKNELL GTS2F400.10539
C Berkshire UK GTS2F400.10540
C RG12 2SZ GTS2F400.10541
C GTS2F400.10542
C If no contract has been raised with this copy of the code, the use, GTS2F400.10543
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.10544
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.10545
C Modelling at the above address. GTS2F400.10546
C ******************************COPYRIGHT****************************** GTS2F400.10547
C GTS2F400.10548
CLL TRANSIN1.3
CLL Subroutine: TRANSIN --------------------------------------- TRANSIN1.4
CLL TRANSIN1.5
CLL Purpose: TRANSIN1.6
CLL To transfer dump data from disk to memory en masse TRANSIN1.7
CLL TRANSIN1.8
CLL Tested under compiler: cft77 TRANSIN1.9
CLL TRANSIN1.10
CLL Tested under OS version: UNICOS 6.1.5A TRANSIN1.11
CLL TRANSIN1.12
CLL Model Modification history from model version 3.0: TRANSIN1.13
CLL version Date TRANSIN1.14
CLL 3.4 16/6/94 : Change CHARACTER*(*) to CHARACTER*(80) N.Farnon ANF0F304.36
CLL 3.3 07/10/93 Corrected order of *CALLs to comdecks TYPSIZE TS071093.4
CLL and TYPD1. Tracey Smith TS071093.5
CLL 3.5 24/03/95 Changed OPEN to FILE_OPEN and GPB1F305.156
CLL CLOSE to FILE_CLOSE P.Burton GPB1F305.157
CLL 4.2 11/10/96 Enable atmos-ocean coupling for MPP. GRR1F402.86
CLL (2): Swap D1 memory. GRR1F402.87
CLL Image of D1 either copied directly from local GRR1F402.88
CLL memory or I/O from file (local to processor) GRR1F402.89
CLL under MPP. I/O kept for mean dumps. R.Rawlins GRR1F402.90
CLL 4.3 30/01/97 Ensure that domain decomposition is consistent GRR0F403.22
CLL with submodel. R.Rawlins GRR0F403.23
CLL 4.4 01/07/97 Make transfers to the input file GBC6F404.207
CLL well-formed. GBC6F404.208
CLL Author: Bob Carruthers, Cray Research. GBC6F404.209
CLL 4.4 11/10/97 Call CNTLALL for L_AO_D1_MEMORY. D. Robinson. GDR5F404.11
CLL 4.4 28/08/97 Minor tidy: replace SETPOS by SETPOS_SINGLE for GRR0F404.1
CLL MPP case. R.Rawlins GRR0F404.2
CLL TRANSIN1.15
CLL Programming standard: TRANSIN1.16
CLL UM Doc Paper 3 TRANSIN1.17
CLL TRANSIN1.18
CLL Logical system components covered: C2 TRANSIN1.19
CLL TRANSIN1.20
CLL Project tasks: C2 TRANSIN1.21
CLL TRANSIN1.22
CLL External documentation: TRANSIN1.23
CLL On-line UM document C5 - Control of means calculations TRANSIN1.24
CLL TRANSIN1.25
CLLEND -------------------------------------------------------------- TRANSIN1.26
C*L Interface and arguments: TRANSIN1.27
SUBROUTINE TRANSIN( 11,13@DYALLOC.3560
*CALL ARGD1 
@DYALLOC.3561
& LEN_DATA,NFTIN,sm_ident GRR1F402.91
& ,ICODE,CMESSAGE) TRANSIN1.29
C TRANSIN1.30
IMPLICIT NONE TRANSIN1.31
C TRANSIN1.32
INTEGER TRANSIN1.33
& LEN_DATA, ! IN Length of model data TRANSIN1.34
& NFTIN, ! IN Unit no for data dump TRANSIN1.35
& sm_ident, ! IN submodel identifier GRR1F402.92
& ICODE ! OUT Return code; successful=0 TRANSIN1.36
* ! error>0 TRANSIN1.37
C TRANSIN1.38
CHARACTER*(80) ANF0F304.37
& CMESSAGE ! OUT Error message if ICODE>0 TRANSIN1.40
C TRANSIN1.41
*CALL TYPSIZE TS071093.6
*CALL TYPD1 TS071093.7
*IF DEF,T3E GBC6F404.210
*CALL CNTL_IO GBC6F404.211
c GBC6F404.212
real local_buffer(um_sector_size) GBC6F404.213
cdir$ cache_align local_buffer GBC6F404.214
*ENDIF GBC6F404.215
C TRANSIN1.44
C Cray specific functions UNIT,LENGTH TRANSIN1.45
C TRANSIN1.46
C External subroutines called TRANSIN1.47
C TRANSIN1.48
EXTERNAL SETPOS GRR0F403.24
*IF DEF,MPP GRR1F402.93
EXTERNAL FORT_GET_ENV,OPEN_SINGLE,CLOSE_SINGLE GRR1F402.94
EXTERNAL BUFFIN_SINGLE,SETPOS_SINGLE GRR0F404.3
EXTERNAL CHANGE_DECOMPOSITION GRR0F403.25
*ELSE GRR1F402.95
EXTERNAL FILE_OPEN,FILE_CLOSE GRR1F402.96
EXTERNAL BUFFIN GRR0F403.26
*ENDIF GRR1F402.97
C TRANSIN1.50
C Local variables TRANSIN1.51
C TRANSIN1.52
INTEGER TRANSIN1.53
& LEN_IO ! No of 64-bit words buffered in/out TRANSIN1.54
& ,I ! loop counter GRR1F402.98
& ,LEN_FILENAME ! Length of FILENAME variable GRR1F402.99
& ,LL ! Character length of filename root GRR1F402.100
& ,decomp_standard ! MPP domain decomposition ident GRR0F403.27
& ,disk_len_1 ! Input length for the first transfer GBC6F404.216
& ,disk_len_2 ! The remainder GBC6F404.217
C TRANSIN1.55
REAL TRANSIN1.56
& A ! Error code from UNIT TRANSIN1.57
GRR1F402.101
LOGICAL GRR1F402.102
& D1_COPY_IN_MEMORY ! T or F: D1 copy in memory or disk GRR1F402.103
GRR1F402.104
CHARACTER GRR1F402.105
& FILENAME*80 ! File name for copy of D1 GRR1F402.106
GRR1F402.107
*CALL PARVARS GRR1F402.108
*CALL DECOMPTP GRR0F403.28
*CALL MPPTRANS GRR1F402.109
*CALL CENVIR TRANSIN1.58
*CALL CSMID GRR1F402.110
*CALL CHSUNITS GDR5F404.12
*CALL CNTLALL GDR5F404.13
GRR1F402.111
*IF DEF,MPP GRR1F402.112
D1_COPY_IN_MEMORY=L_AO_D1_MEMORY ! from COMDECK CNTLALL GDR5F404.14
IF(NFTIN.EQ.FT_MEANDUMP_UNIT) THEN ! Check for dump meaning GRR1F402.114
D1_COPY_IN_MEMORY=.FALSE. GRR1F402.115
ENDIF GRR1F402.116
GRR1F402.117
IF(D1_COPY_IN_MEMORY) THEN ! Read from memory rather than disk GRR1F402.118
*IF DEF,ATMOS,AND,DEF,OCEAN GRR1F402.119
CL GRR1F402.120
CL Copy D1 directly from memory for submodel GRR1F402.121
CL GRR1F402.122
IF(sm_ident.eq.atmos_sm) THEN GRR1F402.123
DO I=1,LEN_DATA GRR1F402.124
D1(I)=D1_A(I) GRR1F402.125
ENDDO ! I GRR1F402.126
ELSEIF(sm_ident.eq.ocean_sm) THEN GRR1F402.127
DO I=1,LEN_DATA GRR1F402.128
D1(I)=D1_O(I) GRR1F402.129
ENDDO ! I GRR1F402.130
ELSE GRR1F402.131
CMESSAGE='TRANSIN: ERROR. Non-valid submodel identifier ' GRR1F402.132
write(6,*) CMESSAGE,sm_ident GRR1F402.133
ICODE=1 GRR1F402.134
GO TO 999 GRR1F402.135
ENDIF GRR1F402.136
*ENDIF GRR1F402.137
write(6,*) 'TRANSIN : Copied from memory LEN_DATA=',LEN_DATA, GRR1F402.138
& 'submodel=',sm_ident GRR1F402.139
GRR1F402.140
ELSE ! Read from disk rather than memory GRR1F402.141
GRR1F402.142
CL GRR1F402.143
CL Read from disk file rather than memory GRR1F402.144
CL GRR1F402.145
LEN_FILENAME=LEN(FILENAME) GRR1F402.146
CALL FORT_GET_ENV(FT_ENVIRON(NFTIN),LEN_FT_ENVIR(NFTIN), GRR1F402.147
& FILENAME,LEN_FILENAME,ICODE) GRR1F402.148
GRR1F402.149
IF(ICODE.NE.0) THEN GRR1F402.150
CMESSAGE='TRANSIN : Environment variable not set ' GRR1F402.151
write(6,*) 'ERROR ',CMESSAGE,FT_ENVIRON(NFTIN) GRR1F402.152
GO TO 999 GRR1F402.153
ENDIF GRR1F402.154
GRR1F402.155
C Search for end of filename GRR1F402.156
LL=0 GRR1F402.157
DO I=1,LEN_FILENAME GRR1F402.158
IF(FILENAME(I:I).ne.' ') THEN GRR1F402.159
LL=LL+1 GRR1F402.160
ENDIF GRR1F402.161
ENDDO ! I over characters GRR1F402.162
GRR1F402.163
C Construct filename with PE no. appended GRR1F402.164
FILENAME(LL+1:LL+1)='.' GRR1F402.165
WRITE(FILENAME(LL+2:LL+5),'(i4.4)') mype GRR1F402.166
CL TRANSIN1.59
CL Read in data TRANSIN1.60
CL GRR1F402.167
CALL OPEN_SINGLE(NFTIN,FILENAME,LL+5,0,1,ICODE) GRR1F402.168
CALL SETPOS_SINGLE(NFTIN,0,ICODE) GRR0F404.4
*IF DEF,T3E GBC6F404.218
c--compute the length of the first read GBC6F404.219
disk_len_1=(len_data/um_sector_size)*um_sector_size GBC6F404.220
call buffin_single(nftin, d1(1), disk_len_1, len_io, a) GBC6F404.221
if(a.ne.-1. .or. len_io.ne.disk_len_1) then GBC6F404.222
write(6,*) 'TRANSIN: Error in data transfer from disk', GBC6F404.223
2 ' A = ',a,' LEN_IO = ',len_io, GBC6F404.224
3 ' Length Requested = ',disk_len_1 GBC6F404.225
icode=1 GBC6F404.226
cmessage='TRANSIN: I/O read error' GBC6F404.227
goto 999 GBC6F404.228
endif GBC6F404.229
c--now the remainder GBC6F404.230
disk_len_2=len_data-disk_len_1 GBC6F404.231
if(disk_len_2.gt.0) then GBC6F404.232
call buffin_single(nftin, local_buffer(1), GBC6F404.233
2 um_sector_size, len_io, a) GBC6F404.234
if(a.ne.-1. .or. len_io.ne.um_sector_size) then GBC6F404.235
write(6,*) 'TRANSIN: Error in data transfer from disk', GBC6F404.236
2 ' A = ',a,' LEN_IO = ',len_io, GBC6F404.237
3 ' Length Requested = ',um_sector_size GBC6F404.238
icode=1 GBC6F404.239
cmessage='TRANSIN: I/O read error' GBC6F404.240
goto 999 GBC6F404.241
endif GBC6F404.242
c--copy the rest of the data over GBC6F404.243
do i=1, disk_len_2 GBC6F404.244
d1(disk_len_1+i)=local_buffer(i) GBC6F404.245
end do GBC6F404.246
endif GBC6F404.247
call close_single(nftin, filename, ll+5, 1, 0, icode) GBC6F404.248
write(6,*) 'TRANSIN: Length transferred = ', len_data GBC6F404.249
*ELSE GBC6F404.250
CALL BUFFIN_SINGLE(NFTIN,D1(1),LEN_DATA,LEN_IO,A) GSM1F403.323
CL GRR1F402.171
CL---------------------------------------------------------------------- GRR1F402.172
CL Check for errors in data transfer from disk GRR1F402.173
CL---------------------------------------------------------------------- GRR1F402.174
CL GRR1F402.175
CALL CLOSE_SINGLE(NFTIN,FILENAME,LL+5,1,0,ICODE) GRR1F402.176
WRITE(6,*) 'TRANSIN: Length transferred=',LEN_IO GIE0F403.646
IF(A.NE.-1.0.OR.LEN_IO.NE.LEN_DATA)THEN GRR1F402.178
WRITE(6,*) 'TRANSIN: Error in data transfer from disk' GIE0F403.647
ICODE=1 GRR1F402.180
CMESSAGE='TRANSIN: I/O read error' GRR1F402.181
GOTO 999 GRR1F402.182
ENDIF GRR1F402.183
*ENDIF GBC6F404.251
ENDIF ! End of disk/memory block GRR1F402.184
GRR1F402.185
*IF DEF,ATMOS,AND,DEF,OCEAN GRR0F403.29
CL GRR0F403.30
CL Ensure that domain decomposition is consistent with submodel GRR0F403.31
CL GRR0F403.32
IF(sm_ident.EQ.atmos_sm) THEN GRR0F403.33
decomp_standard = decomp_standard_atmos GRR0F403.34
ELSEIF(sm_ident.EQ.ocean_sm) THEN GRR0F403.35
decomp_standard = decomp_standard_ocean GRR0F403.36
ENDIF GRR0F403.37
GRR0F403.38
CALL CHANGE_DECOMPOSITION(decomp_standard,ICODE) GRR0F403.39
*ENDIF GRR0F403.40
GRR0F403.41
*ELSE GRR1F402.186
GRR1F402.187
CL GRR1F402.188
CL Read in data (non-MPP) GRR1F402.189
CL TRANSIN1.61
CALL FILE_OPEN(NFTIN,FT_ENVIRON(NFTIN), GPB1F305.158
& LEN_FT_ENVIR(NFTIN),0,0,ICODE) GPB1F305.159
CALL SETPOS(NFTIN,0,ICODE) GTD0F400.131
CALL BUFFIN(NFTIN,D1(1),LEN_DATA,LEN_IO,A) TRANSIN1.65
CL TRANSIN1.66
CL---------------------------------------------------------------------- TRANSIN1.67
CL Check for errors in data transfer from disk TRANSIN1.68
CL---------------------------------------------------------------------- TRANSIN1.69
CL TRANSIN1.70
CALL FILE_CLOSE(NFTIN,FT_ENVIRON(NFTIN),LEN_FT_ENVIR(NFTIN), GTD0F400.38
& 0,0,ICODE) GTD0F400.39
WRITE(6,*) 'TRANSIN: Length transferred=',LEN_IO GIE0F403.648
IF(A.NE.-1.0.OR.LEN_IO.NE.LEN_DATA)THEN TRANSIN1.73
WRITE(6,*) 'TRANSIN: Error in data transfer from disk' GIE0F403.649
ICODE=1 TRANSIN1.75
CMESSAGE='TRANSIN: I/O read error' TRANSIN1.76
GOTO 999 TRANSIN1.77
ENDIF TRANSIN1.78
*ENDIF GRR1F402.190
C TRANSIN1.79
999 CONTINUE TRANSIN1.80
RETURN TRANSIN1.81
END TRANSIN1.82
*ENDIF TRANSIN1.83