*IF DEF,CONTROL TRANSOU1.2
C ******************************COPYRIGHT****************************** GTS2F400.10549
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.10550
C GTS2F400.10551
C Use, duplication or disclosure of this code is subject to the GTS2F400.10552
C restrictions as set forth in the contract. GTS2F400.10553
C GTS2F400.10554
C Meteorological Office GTS2F400.10555
C London Road GTS2F400.10556
C BRACKNELL GTS2F400.10557
C Berkshire UK GTS2F400.10558
C RG12 2SZ GTS2F400.10559
C GTS2F400.10560
C If no contract has been raised with this copy of the code, the use, GTS2F400.10561
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.10562
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.10563
C Modelling at the above address. GTS2F400.10564
C ******************************COPYRIGHT****************************** GTS2F400.10565
C GTS2F400.10566
CLL Subroutine: TRANSOUT ----------------------------------------- TRANSOU1.3
CLL TRANSOU1.4
CLL Purpose: TRANSOU1.5
CLL To transfer dump data from memory to disk en masse TRANSOU1.6
CLL TRANSOU1.7
CLL Tested under compiler: cft77 TRANSOU1.8
CLL Tested under OS version: UNICOS 6.1.5A TRANSOU1.9
CLL TS071093.8
CLL Model TS071093.9
CLL version Date Modification history: TS071093.10
CLL 3.3 07/10/93 Corrected order of *CALLs to comdecks TYPSIZE TS071093.11
CLL and TYPD1. Tracey Smith TS071093.12
CLL TRANSOU1.10
CLL Programming standard: TRANSOU1.11
CLL UM Doc Paper 3 TRANSOU1.12
CLL TRANSOU1.13
CLL Logical system components covered: C2 TRANSOU1.14
CLL TRANSOU1.15
CLL Project tasks: C2 TRANSOU1.16
CLL TRANSOU1.17
CLL External documentation: TRANSOU1.18
CLL On-line UM document C5 - Control of means calculations TRANSOU1.19
CLL Model Modification history from model version 3.4: ANF0F304.38
CLL version Date ANF0F304.39
CLL 3.4 16/6/94 : Change CHARACTER*(*) to CHARACTER*(80) N.Farnon ANF0F304.40
CLL 3.5 24/03/95 Changed OPEN to FILE_OPEN and GPB1F305.162
CLL CLOSE to FILE_CLOSE P.Burton GPB1F305.163
CLL 4.2 11/10/96 Enable atmos-ocean coupling for MPP. GRR1F402.191
CLL (2): Swap D1 memory. GRR1F402.192
CLL Image of D1 either copied directly from local GRR1F402.193
CLL memory or I/O from file (local to processor) GRR1F402.194
CLL under MPP. I/O kept for mean dumps. R.Rawlins GRR1F402.195
CLL 4.4 01/07/97 Make transfers to the input file GBC6F404.252
CLL well-formed. GBC6F404.253
CLL Author: Bob Carruthers, Cray Research. GBC6F404.254
CLL 4.4 11/10/97 Call CNTLALL for L_AO_D1_MEMORY. D. Robinson. GDR5F404.7
CLL 4.4 28/08/97 Minor tidy: replace SETPOS by SETPOS_SINGLE for GRR0F404.5
CLL MPP case. R.Rawlins GRR0F404.6
CLL TRANSOU1.20
CLLEND--------------------------------------------------------------- TRANSOU1.21
C*L Interface and arguments: TRANSOU1.22
SUBROUTINE TRANSOUT( 9,12@DYALLOC.3565
*CALL ARGD1 
@DYALLOC.3566
& LEN_DATA,NFTOUT,sm_ident GRR1F402.196
& ,ICODE,CMESSAGE) TRANSOU1.24
C TRANSOU1.25
IMPLICIT NONE TRANSOU1.26
C TRANSOU1.27
INTEGER TRANSOU1.28
& LEN_DATA, ! IN Length of model data TRANSOU1.29
& NFTOUT, ! IN Unit no for data dump TRANSOU1.30
& sm_ident, ! IN submodel identifier GRR1F402.197
& ICODE ! OUT Return code; successful=0 TRANSOU1.31
* ! error>0 TRANSOU1.32
C TRANSOU1.33
CHARACTER*(80) ANF0F304.41
& CMESSAGE ! OUT Error message if ICODE>0 TRANSOU1.35
C TRANSOU1.36
*CALL TYPSIZE TS071093.13
*CALL TYPD1 TS071093.14
*IF DEF,T3E GBC6F404.255
*CALL CNTL_IO GBC6F404.256
c GBC6F404.257
real local_buffer(um_sector_size) GBC6F404.258
cdir$ cache_align local_buffer GBC6F404.259
*ENDIF GBC6F404.260
C TRANSOU1.39
C Cray specific functions UNIT,LENGTH TRANSOU1.40
C TRANSOU1.41
C External subroutines called TRANSOU1.42
C TRANSOU1.43
EXTERNAL SETPOS,BUFFOUT TRANSOU1.44
*IF DEF,MPP GRR1F402.198
EXTERNAL FORT_GET_ENV,OPEN_SINGLE,CLOSE_SINGLE GRR1F402.199
EXTERNAL BUFFIN_SINGLE,SETPOS_SINGLE GRR0F404.7
*ELSE GRR1F402.200
EXTERNAL FILE_OPEN,FILE_CLOSE GRR1F402.201
*ENDIF GRR1F402.202
C TRANSOU1.45
C Local variables TRANSOU1.46
C TRANSOU1.47
INTEGER TRANSOU1.48
& LEN_IO ! No of 64-bit words buffered in/out TRANSOU1.49
& ,I ! loop counter GRR1F402.203
& ,LEN_FILENAME ! Length of FILENAME variable GRR1F402.204
& ,LL ! Character length of filename root GRR1F402.205
& ,disk_len_1 ! Input length for the first transfer GBC6F404.261
& ,disk_len_2 ! The remainder GBC6F404.262
C TRANSOU1.50
REAL TRANSOU1.51
& A ! Error code from UNIT TRANSOU1.52
GRR1F402.206
LOGICAL GRR1F402.207
& D1_COPY_IN_MEMORY ! T or F: D1 copy in memory or disk GRR1F402.208
GRR1F402.209
CHARACTER GRR1F402.210
& FILENAME*80 ! File name for copy of D1 GRR1F402.211
GRR1F402.212
*CALL PARVARS GRR1F402.213
*CALL MPPTRANS GRR1F402.214
*CALL CENVIR TRANSOU1.53
*CALL CSMID GRR1F402.215
*CALL CHSUNITS GDR5F404.8
*CALL CNTLALL GDR5F404.9
GRR1F402.216
*IF DEF,MPP GRR1F402.217
D1_COPY_IN_MEMORY=L_AO_D1_MEMORY ! from COMDECK CNTLALL GDR5F404.10
IF(NFTOUT.EQ.FT_MEANDUMP_UNIT) THEN ! Check for dump meaning GRR1F402.219
D1_COPY_IN_MEMORY=.FALSE. GRR1F402.220
ENDIF GRR1F402.221
GRR1F402.222
IF(D1_COPY_IN_MEMORY) THEN ! Write to memory rather than disk GRR1F402.223
*IF DEF,ATMOS,AND,DEF,OCEAN GRR1F402.224
CL GRR1F402.225
CL Copy D1 directly into memory for submodel GRR1F402.226
CL GRR1F402.227
IF(sm_ident.eq.atmos_sm) THEN GRR1F402.228
DO I=1,LEN_DATA GRR1F402.229
D1_A(I)=D1(I) GRR1F402.230
ENDDO ! I GRR1F402.231
ELSEIF(sm_ident.eq.ocean_sm) THEN GRR1F402.232
DO I=1,LEN_DATA GRR1F402.233
D1_O(I)=D1(I) GRR1F402.234
ENDDO ! I GRR1F402.235
ELSE GRR1F402.236
CMESSAGE='TRANSOUT: ERROR. Non-valid submodel identifier ' GRR1F402.237
write(6,*) CMESSAGE,sm_ident GRR1F402.238
ICODE=1 GRR1F402.239
GO TO 999 GRR1F402.240
ENDIF GRR1F402.241
*ENDIF GRR1F402.242
write(6,*) 'TRANSOUT: Copied into memory LEN_DATA=',LEN_DATA, GRR1F402.243
& 'submodel=',sm_ident GRR1F402.244
GRR1F402.245
ELSE ! Write to disk rather than memory GRR1F402.246
GRR1F402.247
LEN_FILENAME=LEN(FILENAME) GRR1F402.248
CALL FORT_GET_ENV(FT_ENVIRON(NFTOUT),LEN_FT_ENVIR(NFTOUT), GRR1F402.249
& FILENAME,LEN_FILENAME,ICODE) GRR1F402.250
GRR1F402.251
IF(ICODE.NE.0) THEN GRR1F402.252
CMESSAGE='TRANSOUT: Environment variable not set ' GRR1F402.253
write(6,*) 'ERROR ',CMESSAGE,FT_ENVIRON(NFTOUT) GRR1F402.254
GO TO 999 GRR1F402.255
ENDIF GRR1F402.256
GRR1F402.257
C Search for end of filename GRR1F402.258
LL=0 GRR1F402.259
DO I=1,LEN_FILENAME GRR1F402.260
IF(FILENAME(I:I).ne.' ') THEN GRR1F402.261
LL=LL+1 GRR1F402.262
ENDIF GRR1F402.263
ENDDO ! I over characters GRR1F402.264
GRR1F402.265
C Construct filename with PE no. appended GRR1F402.266
FILENAME(LL+1:LL+1)='.' GRR1F402.267
WRITE(FILENAME(LL+2:LL+5),'(i4.4)') mype GRR1F402.268
CL TRANSOU1.54
CL Write out data TRANSOU1.55
CL GRR1F402.269
CALL OPEN_SINGLE(NFTOUT,FILENAME,LL+5,1,1,ICODE) GRR1F402.270
CALL SETPOS_SINGLE(NFTOUT,0,ICODE) GRR0F404.8
*IF DEF,T3E GBC6F404.263
c--compute the length of the first write GBC6F404.264
disk_len_1=(len_data/um_sector_size)*um_sector_size GBC6F404.265
call buffout_single(nftout, d1(1), disk_len_1, len_io, a) GBC6F404.266
if(a.ne.-1. .or. len_io.ne.disk_len_1) then GBC6F404.267
write(6,*) 'TRANSOUT: Error in data transfer to disk', GBC6F404.268
2 ' A = ',a,' LEN_IO = ',len_io, GBC6F404.269
3 ' Length Requested = ',disk_len_1 GBC6F404.270
icode=1 GBC6F404.271
cmessage='TRANSOUT: I/O write error' GBC6F404.272
goto 999 GBC6F404.273
endif GBC6F404.274
c--now the remainder GBC6F404.275
disk_len_2=len_data-disk_len_1 GBC6F404.276
if(disk_len_2.gt.0) then GBC6F404.277
c--copy the rest of the data over GBC6F404.278
do i=1, disk_len_2 GBC6F404.279
local_buffer(i)=d1(disk_len_1+i) GBC6F404.280
end do GBC6F404.281
c--now output the remainder GBC6F404.282
call buffout_single(nftout, local_buffer(1), GBC6F404.283
2 um_sector_size, len_io, a) GBC6F404.284
if(a.ne.-1. .or. len_io.ne.um_sector_size) then GBC6F404.285
write(6,*) 'TRANSOUT: Error in data transfer to disk', GBC6F404.286
2 ' A = ',a,' LEN_IO = ',len_io, GBC6F404.287
3 ' Length Requested = ',um_sector_size GBC6F404.288
icode=1 GBC6F404.289
cmessage='TRANSOUT: I/O write error' GBC6F404.290
goto 999 GBC6F404.291
endif GBC6F404.292
endif GBC6F404.293
call close_single(nftout, filename, ll+5, 1, 0, icode) GBC6F404.294
write(6,*) 'TRANSOUT: Length transferred = ', len_data GBC6F404.295
*ELSE GBC6F404.296
CALL BUFFOUT_SINGLE(NFTOUT,D1(1),LEN_DATA,LEN_IO,A) GSM1F403.321
CL GRR1F402.273
CL---------------------------------------------------------------------- GRR1F402.274
CL Check for errors in data transfer to disk GRR1F402.275
CL---------------------------------------------------------------------- GRR1F402.276
CL GRR1F402.277
CALL CLOSE_SINGLE(NFTOUT,FILENAME,LL+5,1,0,ICODE) GRR1F402.278
WRITE(6,*) 'TRANSOUT: Length transferred=',LEN_IO GIE0F403.650
IF(A.NE.-1.0.OR.LEN_IO.NE.LEN_DATA)THEN GRR1F402.280
WRITE(6,*) 'TRANSOUT: Error in data transfer to disk' GIE0F403.651
ICODE=1 GRR1F402.282
CMESSAGE='TRANSOUT: I/O write error' GRR1F402.283
GOTO 999 GRR1F402.284
ENDIF GRR1F402.285
*ENDIF GBC6F404.297
ENDIF ! End of disk/memory block GRR1F402.286
GRR1F402.287
*ELSE GRR1F402.288
CL GRR1F402.289
CL Write out data (non-MPP) GRR1F402.290
CL TRANSOU1.56
CALL FILE_OPEN(NFTOUT,FT_ENVIRON(NFTOUT), GPB1F305.164
& LEN_FT_ENVIR(NFTOUT),1,0,ICODE) GPB1F305.165
CALL SETPOS(NFTOUT,0,ICODE) GTD0F400.132
CALL BUFFOUT(NFTOUT,D1(1),LEN_DATA,LEN_IO,A) TRANSOU1.60
CL TRANSOU1.61
CL---------------------------------------------------------------------- TRANSOU1.62
CL Check for errors in data transfer to disk TRANSOU1.63
CL---------------------------------------------------------------------- TRANSOU1.64
CL TRANSOU1.65
CALL FILE_CLOSE(NFTOUT,FT_ENVIRON(NFTOUT),LEN_FT_ENVIR(NFTOUT) GTD0F400.40
& ,0,0,ICODE) GTD0F400.41
WRITE(6,*) 'TRANSOUT: Length transferred=',LEN_IO GIE0F403.652
IF(A.NE.-1.0.OR.LEN_IO.NE.LEN_DATA)THEN TRANSOU1.68
WRITE(6,*) 'TRANSOUT: Error in data transfer to disk' GIE0F403.653
ICODE=1 TRANSOU1.70
CMESSAGE='TRANSOUT: I/O write error' TRANSOU1.71
GOTO 999 TRANSOU1.72
ENDIF TRANSOU1.73
*ENDIF GRR1F402.291
C TRANSOU1.74
999 CONTINUE TRANSOU1.75
RETURN TRANSOU1.76
END TRANSOU1.77
*ENDIF TRANSOU1.78