*IF DEF,CONTROL UMSHELL1.2
C ******************************COPYRIGHT****************************** GTS2F400.10765
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.10766
C GTS2F400.10767
C Use, duplication or disclosure of this code is subject to the GTS2F400.10768
C restrictions as set forth in the contract. GTS2F400.10769
C GTS2F400.10770
C Meteorological Office GTS2F400.10771
C London Road GTS2F400.10772
C BRACKNELL GTS2F400.10773
C Berkshire UK GTS2F400.10774
C RG12 2SZ GTS2F400.10775
C GTS2F400.10776
C If no contract has been raised with this copy of the code, the use, GTS2F400.10777
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.10778
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.10779
C Modelling at the above address. GTS2F400.10780
C ******************************COPYRIGHT****************************** GTS2F400.10781
C GTS2F400.10782
CLL Program: UM_SHELL ------------------------------------------------- UMSHELL1.3
CLL UMSHELL1.4
CLL Purpose: Outermost shell of control program for the Unified Model. UMSHELL1.5
CLL Acquires size information needed for dynamic allocation of UMSHELL1.6
CLL configuration-dependent arrays and calls U_MODEL (the UMSHELL1.7
CLL master control routine) to allocate the arrays and perform UMSHELL1.8
CLL the top-level control functions and timestepping. UMSHELL1.9
CLL UMSHELL1.10
CLL Tested under compiler: cft77 UMSHELL1.11
CLL Tested under OS version: UNICOS 6.1.5A UMSHELL1.12
CLL UMSHELL1.13
CLL Model Modification history: UMSHELL1.14
CLL version date UMSHELL1.15
CLL 3.2 30/03/93 Introduced as new DECK to allow dynamic allocation UMSHELL1.16
CLL of main data arrays in U_MODEL. UMSHELL1.17
CLL 3.3 30/09/93 Option on frequency of convection scheme calls. RB300993.151
CLL R.T.H.Barnes. RB300993.152
! 3.5 28/03/95 Open UNIT05 as a file rather than stdin GPB0F305.1
! P. Burton GPB0F305.2
CLL 3.5 Apr. 95 Submodels project: GSS1F305.843
CLL Introduce CALL STASH_PROC. This is the top-level GSS1F305.844
CLL control routine for processing of STASH requests GSS1F305.845
CLL and STASH addressing. Up to UM vn. 3.4, these GSS1F305.846
CLL functions were performed by the user interface GSS1F305.847
CLL processing routines. Introduce argument ppxRecs GSS1F400.722
CLL into U_MODEL - for dynamic allocation of ppxref GSS1F400.723
CLL look-up arrays in U_MODEL. GSS1F400.724
CLL S.J.Swarbrick GSS1F305.851
CLL 4.0 18/10/95 Add ICODE error return to GET_FILE call. RTHBarnes GRB2F400.3
CLL 4.1 14/03/96 Introduce Wave sub-model. RTHBarnes. WRB1F401.1117
CLL 4.1 22/05/96 Replaced *DEF FAST with FRADIO to allow fast GGH3F401.34
CLL radiation i/o code to be used. G Henderson GGH3F401.35
CLL 4.1 May 96 Restructure calls to HDPPXRF - for new GSS2F401.464
CLL STASHmaster file system. GSS2F401.465
CLL STASHmaster now read by FORTRAN i/o (not C i/o), so GSS2F401.466
CLL unit no. changed from 1 to 22 - unit 1 already in GSS2F401.467
CLL use for FORTRAN i/o (HK_FILE). GSS2F401.468
CLL Unit 22 was lowest unit no. (apparently) GSS2F401.469
CLL available for FORTRAN i/o. S.J.Swarbrick GSS2F401.470
!LL 4.2 21/08/96 MPP code : Added flexible decompositions, GPB0F402.293
!LL replacing DECOMPOSE_DATA by DECOMPOSE_ATMOS GPB0F402.294
!LL and adding DECOMPOSE_OCN, and calling GPB0F402.295
!LL CHANGE_DECOMP to set to atmosphere decomposition. GPB0F402.296
!LL Removed the calls to set up GCOM groups. GPB0F402.297
!LL Added code to find out ocean decomposition GPB0F402.298
!LL from environment variables GPB0F402.299
!LL P.Burton GPB0F402.300
CLL 4.2 27/11/96 Changes to parallelise writes to archiving system GLW2F402.94
CLL L. Wiles GLW2F402.95
!LL 4.3 19/03/97 Find out the clock tick rate - required for GPB3F403.162
!LL producing timer information. P.Burton GPB3F403.163
!LL 4.3 18/02/97 Added l_ocyclic arg to decomp_ocean P.Burton GPB2F403.118
!LL 4.3 30/04/97 Added code to read the UM_SECTOR_SIZE from the GBC0F403.1
!LL Shell variable of the same name. GBC0F403.2
!LL B. Carruthers Cray Research. GBC0F403.3
!LL 4.3 09/05/97 Added code to read the UM_RNL_SKIP from the GBC0F403.4
!LL Shell variable of the same name. GBC0F403.5
!LL B. Carruthers Cray Research. GBC0F403.6
!LL 4.4 11/07/97 Check nproc_max is LE to MAXPROC P.Burton GPB1F404.75
CLL 4.4 Oct. 1997 Changed the error handling from subroutine GDW1F404.99
CLL HDPPXRF. Now a -ve error code indicates GDW1F404.100
CLL a warning and a +ve indicates a fatal GDW1F404.101
CLL problem. Currently the latter only occurs GDW1F404.102
CLL if the STASHmaster version differs from the GDW1F404.103
CLL running version of the UM. GDW1F404.104
CLL Shaun de Witt GDW1F404.105
! 4.4 30/09/97 Added code to permit the SHMEM/NAM timeout GBCAF404.8
! value to be set from a shell variable. GBCAF404.9
! Author: Bob Carruthers Cray Research. GBCAF404.10
! 4.4 18/09/97 Remove the code for GET_CHAR_LEN, and turn GBC6F404.314
! it into a separate deck. GBC6F404.315
! Author: Bob Carruthers Cray Research. GBC6F404.316
!LL 4.5 08/01/98 Ensure any old unit6 output files are deleted GPB0F405.19
!LL before the new one is opened. P.Burton GPB0F405.20
! 4.5 08/07/98 Print only the leading non-blank GBC1F405.29
! characters in 'cmessage' GBC1F405.30
! Author: Bob Carruthers, Cray Research GBC1F405.31
! 4.5 17/08/98 Check return codes from calls to HDPPXRF. GBCKF405.1
! Author: Bob Carruthers Cray Research. GBCKF405.2
!LL 4.5 29/07/98 Call DERV_INTF_A. D. Robinson. GDR2F405.167
! 4.5 17/08/98 Print date/time at start and end of UM Job. GDR3F405.1
! D. Robinson. GDR3F405.2
!LL 4.5 15/04/98 Call DERV_LAND_FIELD. D. Robinson. GDR5F405.1
!LL 4.5 29/07/98 Call DERV_INTF_O. P. Horrocks. GMB1F405.560
! 4.5 20/01/98 Changed default sector size to 2048 P.Burton GPB0F405.27
CLL UMSHELL1.18
CLL Programming standard: UM Doc Paper 3, version 2 (7/9/90) UMSHELL1.19
CLL UMSHELL1.20
CLL Logical components covered: C0 UMSHELL1.21
CLL UMSHELL1.22
CLL Project task: C0 UMSHELL1.23
CLL UMSHELL1.24
CLL External documentation: On-line UM document C1 - The top-level UMSHELL1.25
CLL dynamic allocation UMSHELL1.26
CLL UMSHELL1.27
CLL ------------------------------------------------------------------- UMSHELL1.28
C*L Interface and arguments: ------------------------------------------ UMSHELL1.29
C UMSHELL1.30
PROGRAM UM_SHELL ,45UMSHELL1.31
C UMSHELL1.32
C*---------------------------------------------------------------------- UMSHELL1.33
IMPLICIT NONE UMSHELL1.34
C UMSHELL1.35
C Subroutines called UMSHELL1.36
C UMSHELL1.37
EXTERNAL TIMER,READSIZE,UM_INDEX,U_MODEL,ABORT UMSHELL1.38
*IF DEF,ATMOS,AND,DEF,MPP GDR5F405.2
& ,DERV_LAND_FIELD GDR5F405.3
*ENDIF GDR5F405.4
& ,HDPPXRF,STASH_PROC GSS1F305.852
*IF DEF,ATMOS GDR2F405.168
& ,DERV_INTF_A GDR2F405.169
*ENDIF GDR2F405.170
*IF DEF,OCEAN GMB1F405.561
& ,DERV_INTF_O GMB1F405.562
*ENDIF GMB1F405.563
C UMSHELL1.39
C Local variables UMSHELL1.40
C UMSHELL1.41
*IF DEF,CRI_FFIO GBC0F403.72
real secondr, close_time GBC0F403.73
*ENDIF GBC0F403.74
INTEGER ICODE ! Work - Internal return code UMSHELL1.42
INTEGER ISTATUS ! RETURN STATUS FROM OPEN GPB0F305.3
CHARACTER*80 FILENAME ! RETURN FILENAME FROM GET_FILE GPB0F305.4
CHARACTER*256 CMESSAGE ! Work - Internal error message UMSHELL1.43
*IF DEF,MPP GPB0F305.97
INTEGER local_row_len, ! new row_len after decomposition GPB0F305.98
& local_p_rows, ! new number of rows afer decomposition GPB0F305.99
*IF DEF,ATMOS GPB0F402.301
& atm_nprocx, ! number of procs EW for atmosphere GPB0F402.302
& atm_nprocy, ! number of procs NS for atmosphere GPB0F402.303
*ENDIF GPB0F402.304
*IF DEF,OCEAN GPB0F402.305
& ocn_nprocx, ! number of procs EW for ocean GPB0F402.306
& ocn_nprocy, ! number of procs NS for ocean GPB0F402.307
*ENDIF GPB0F402.308
& err ! error return from FORT_GET_ENV GPB0F402.309
GPB0F402.310
CHARACTER*8 c_nproc ! to get nproc_x and nproc_y from GPB0F402.311
! ! environment variables. GPB0F401.212
CHARACTER*100 parexe_env ! to hold the name of the parallel GPB0F401.213
! ! executable script GPB0F401.214
CHARACTER*200 stdout_filename ! file to write stdout to APB1F402.277
CHARACTER*180 stdout_basename ! base of filename APB1F402.278
CHARACTER*170 dataw_char ! value of $DATAW APB1F402.279
CHARACTER*5 runid_char ! value of $RUNID APB1F402.280
INTEGER len_basename,len_dataw,len_runid ! lengths of chars. APB1F402.281
INTEGER GET_CHAR_LEN ! function to return true length of APB1F402.282
! ! character variable APB1F402.283
GPB0F305.103
*CALL DECOMPTP 
GPB0F402.312
*CALL PARVARS GPB0F305.104
*CALL GCCOM GBCAF404.11
c GBCAF404.12
integer um_nam_max_seconds GBCAF404.13
c GBCAF404.14
character*8 c_nam_max_seconds GBCAF404.15
*ELSE GBC1F405.32
INTEGER GET_CHAR_LEN ! function to return true length of a GBC1F405.33
! ! character GBC1F405.34
*ENDIF GPB0F305.105
C UMSHELL1.44
C Configuration-dependent sizes for dynamic arrays UMSHELL1.45
C UMSHELL1.46
*CALL CSUBMODL GSS1F305.853
*CALL TYPSIZE UMSHELL1.47
C UMSHELL1.48
C Super array sizes for dynamic allocation in U_MODEL UMSHELL1.49
C UMSHELL1.50
*CALL TYPSZSP UMSHELL1.51
*CALL TYPSZSPA UMSHELL1.52
*CALL TYPSZSPO UMSHELL1.53
*CALL TYPSZSPW WRB1F401.1118
*CALL TYPSZSPC UMSHELL1.54
C UMSHELL1.55
! Declare ppxref look-up arrays, pointer array, and associated GSS1F305.854
! sizes. The lengths (ppxRecs) of the ppx look-up arrays are GSS1F305.855
! dynamically allocated. GSS1F305.856
*CALL CPPXREF GSS1F305.857
*CALL VERSION GSS1F305.858
*CALL CSTASH GRB0F401.1
! Length of ppx look-up arrays - for dynamic allocation GSS1F400.726
INTEGER ppxRecs GSS1F400.727
*CALL CHSUNITS GSM1F401.22
*CALL CCONTROL GSM1F401.23
*CALL CNTL_IO GBC0F403.7
c GBC0F403.8
*IF DEF,SGI PXUMSHEL.1
integer sect_err, rnl_err PXUMSHEL.2
integer (kind=4) um_rnl_skip PXUMSHEL.3
*ELSE PXUMSHEL.4
integer sect_err, rnl_err, um_rnl_skip PXUMSHEL.5
*ENDIF PXUMSHEL.6
c GBC0F403.10
character*8 c_um_sector_size, c_um_rnl_skip GBC0F403.11
character*8 ch_date2 ! Date returned from date_and_time GDR3F405.3
character*10 ch_time2 ! Time returned from date_and_time GDR3F405.4
GSS1F305.862
*IF DEF,T3E GPB3F403.164
*CALL T3ECLKTK GPB3F403.165
INTEGER iclktck,ierr GPB3F403.166
*ENDIF GPB3F403.167
! Fortran unit numbers GSS1F305.863
INTEGER NFTPPXREF GSS1F305.864
INTEGER NFTSTMSTU GSS1F305.865
DATA NFTPPXREF/22/,NFTSTMSTU/2/ GSS2F401.471
GSS1F305.867
GDW1F404.106
cmessage = ' ' GDW1F404.107
CL---------------------------------------------------------------------- UMSHELL1.56
CL 0. Start Timer running UMSHELL1.57
CL UMSHELL1.58
*IF DEF,T3E GPB3F403.168
! Find out the number of clock ticks per second on this machine. GPB3F403.169
! This information is required to calculate the wallclock times GPB3F403.170
! in TIMER GPB3F403.171
GPB3F403.172
iclktck=0 GPB3F403.173
ticks_per_second=0 GPB3F403.174
GPB3F403.175
CALL PXFCONST('CLK_TCK',iclktck,ierr) GPB3F403.176
GPB3F403.177
IF (ierr .NE. 0) THEN GPB3F403.178
WRITE(6,*) 'UMSHELL : Failure in PXFCONST, err= ',ierr GPB3F403.179
ICODE=1 GPB3F403.180
GOTO 999 GPB3F403.181
ENDIF GPB3F403.182
GPB3F403.183
CALL PXFSYSCONF(iclktck,ticks_per_second,ierr) GPB3F403.184
GPB3F403.185
IF (ierr .NE. 0) THEN GPB3F403.186
WRITE(6,*) 'UMSHELL : Failure in PXFSYSCONF, err= ',ierr GPB3F403.187
ICODE=1 GPB3F403.188
GOTO 999 GPB3F403.189
ENDIF GPB3F403.190
GPB3F403.191
*ENDIF GPB3F403.192
*IF -DEF,SGI PXUMSHEL.7
! Open file for UNIT 5 before initialisation of model. All runtime GPB0F305.5
! control variables subsequently read in from UNIT 5 by namelist. GPB0F305.6
CALL GET_FILE(5,FILENAME,80,ICODE) GRB2F400.4
OPEN(5,FILE=FILENAME,IOSTAT=ISTATUS,DELIM='APOSTROPHE') PXNAMLST.21
IF(ISTATUS.NE.0) THEN GPB0F305.9
ICODE=500 GPB0F305.10
WRITE(6,*) ' ERROR OPENING FILE ON UNIT 5' GPB0F305.11
WRITE(6,*) ' FILENAME =',FILENAME GPB0F305.12
WRITE(6,*) ' IOSTAT =',ISTATUS GPB0F305.13
GOTO 999 GPB0F305.14
END IF GPB0F305.15
CL------------------------------------------------------------------ GRR2F305.293
CL 0.1 Get submodel/internal model components of model run. GRR2F305.294
CL GRR2F305.295
ICODE=0 GRR2F305.296
CALL UM_Submodel_Init(ICODE) GRR2F305.297
*ENDIF PXUMSHEL.8
GBC0F403.12
CL GBC0F403.13
CL Get the current sector size for disk I/O GBC0F403.14
CL GBC0F403.15
GBC0F403.16
CALL FORT_GET_ENV('UM_SECTOR_SIZE',14,c_um_sector_size,8,sect_err) GBC0F403.17
IF (sect_err .NE. 0) THEN GBC0F403.18
WRITE(6,*) 'Warning: Environment variable UM_SECTOR_SIZE has ', GBC0F403.19
& 'not been set.' GBC0F403.20
WRITE(6,*) 'Setting um_sector_size to 2048' GPB0F405.28
um_sector_size=2048 GPB0F405.29
ELSE GBC0F403.23
READ(c_um_sector_size,'(I4)') um_sector_size GBC0F403.24
ENDIF GBC0F403.25
*IF DEF,CRAY GBC0F403.26
GBC0F403.27
CL GBC0F403.28
CL Get the current NAMELIST Skip value GBC0F403.29
CL GBC0F403.30
GBC0F403.31
CALL FORT_GET_ENV('UM_RNL_SKIP',11,c_um_rnl_skip,8,rnl_err) GBC0F403.32
IF (rnl_err .NE. 0) THEN GBC0F403.33
WRITE(6,*) 'Warning: Environment variable UM_RNL_SKIP has ', GBC0F403.34
& 'not been set.' GBC0F403.35
WRITE(6,*) 'Setting um_rnl_skip to 0 - Omit Skipped Messages' GBC0F403.36
um_rnl_skip=0 GBC0F403.37
ELSE GBC0F403.38
READ(c_um_rnl_skip,'(I4)') um_rnl_skip GBC0F403.39
ENDIF GBC0F403.40
call rnlskip(um_rnl_skip) GBC0F403.41
*ENDIF GBC0F403.42
GRR2F305.298
CL---------------------------------------------------------------------- UMSHELL1.60
*IF DEF,MPP GPB0F305.106
!---------------------------------------------------------------------- GPB0F305.107
! 1.0 Initialise Message Passing Libraries GPB0F305.108
! GPB0F305.109
GPB0F305.110
*IF DEF,ATMOS GPB0F402.313
! Get the atmosphere decomposition GPB0F402.314
GPB0F305.113
CALL FORT_GET_ENV('UM_ATM_NPROCX',13,c_nproc,8,err) GPB0F402.315
IF (err .NE. 0) THEN GPB0F305.115
WRITE(6,*) 'Warning: Environment variable UM_ATM_NPROCX has ', GPB0F402.316
& 'not been set.' GPB0F305.117
WRITE(6,*) 'Setting nproc_x to 1' GPB0F305.118
atm_nprocx=1 GPB0F402.317
ELSE GPB0F305.120
READ(c_nproc,'(I4)') atm_nprocx GPB0F402.318
ENDIF GPB0F305.122
CALL FORT_GET_ENV('UM_ATM_NPROCY',13,c_nproc,8,err) GPB0F402.319
IF (err .NE. 0) THEN GPB0F305.124
WRITE(6,*) 'Warning: Environment variable UM_ATM_NPROCY has ', GPB0F402.320
& 'not been set.' GPB0F305.126
WRITE(6,*) 'Setting nproc_y to 1' GPB0F305.127
atm_nprocy=1 GPB0F402.321
ELSE GPB0F305.129
READ(c_nproc,'(I4)') atm_nprocy GPB0F402.322
ENDIF GPB0F305.131
*ENDIF GPB0F402.323
GPB0F402.324
*IF DEF,OCEAN GPB0F402.325
! Get the ocean decomposition GPB0F402.326
GPB0F402.327
CALL FORT_GET_ENV('UM_OCN_NPROCX',13,c_nproc,8,err) GPB0F402.328
IF (err .NE. 0) THEN GPB0F402.329
WRITE(6,*) 'Warning: Environment variable UM_OCN_NPROCX ', GPB0F402.330
& 'has not been set.' GPB0F402.331
WRITE(6,*) 'Setting nproc_x to 1' GPB0F402.332
ocn_nprocx=1 GPB0F402.333
ELSE GPB0F402.334
READ(c_nproc,'(I4)') ocn_nprocx GPB0F402.335
IF (ocn_nprocx .NE. 1) THEN GPB0F402.336
WRITE(6,*) 'Warning : The ocean code does not yet support ', GPB0F402.337
& 'decomposition along rows.' GPB0F402.338
WRITE(6,*) 'Setting nproc_x to 1' GPB0F402.339
ENDIF GPB0F402.340
ENDIF GPB0F402.341
GPB0F402.342
CALL FORT_GET_ENV('UM_OCN_NPROCY',13,c_nproc,8,err) GPB0F402.343
IF (err .NE. 0) THEN GPB0F402.344
WRITE(6,*) 'Warning: Environment variable UM_OCN_NPROCY ', GPB0F402.345
& 'has not been set.' GPB0F402.346
WRITE(6,*) 'Setting nproc_y to 1' GPB0F402.347
ocn_nprocy=1 GPB0F402.348
ELSE GPB0F402.349
READ(c_nproc,'(I4)') ocn_nprocy GPB0F402.350
ENDIF GPB0F402.351
GPB0F402.352
*ENDIF GPB0F402.353
GPB0F402.354
GPB0F305.149
! Find out the maximum number of processors to be used in this GPB0F402.355
! run of the model GPB0F402.356
GPB0F402.357
CALL FORT_GET_ENV('UM_NPES',7,c_nproc,8,err) GPB0F402.358
IF ( (err .NE. 0) .OR. (c_nproc .EQ. 'UNSET') ) THEN GPB0F402.359
WRITE(6,*) 'Error : Environment variable UM_NPES has ', GPB0F402.360
& 'not been set.' GPB0F402.361
WRITE(6,*) 'Exiting' GPB0F402.362
GOTO 999 GPB0F402.363
ENDIF GPB0F402.364
GPB0F402.365
READ(c_nproc,'(I4)') nproc_max GPB0F402.366
GPB1F404.76
! Check MAXPROC is big enough for nproc_max GPB1F404.77
GPB1F404.78
IF (nproc_max .GT. MAXPROC) THEN GPB1F404.79
WRITE(6,*) 'Error : MAXPROC is not big enough.' GPB1F404.80
WRITE(6,*) 'You will need to edit the parameter in comdeck ', GPB1F404.81
& 'PARPARM.' GPB1F404.82
WRITE(6,*) 'MAXPROC= ',MAXPROC,' nproc_max= ',nproc_max GPB1F404.83
WRITE(6,*) 'Exiting' GPB1F404.84
GOTO 999 GPB1F404.85
ENDIF GPB1F404.86
GPB0F402.367
*IF DEF,ATMOS GPB0F402.368
! Check that there are enough processors to support the GPB0F402.369
! decompositions that have been requested. GPB0F402.370
GPB0F402.371
IF ((atm_nprocx*atm_nprocy) .NE. nproc_max ) THEN GPB0F402.372
WRITE(6,*) 'Error : Atmosphere decomposition of ',atm_nprocx, GPB0F402.373
& ' x ',atm_nprocy,' processors cannot be supported ', GPB0F402.374
& 'using ',nproc_max,' processors.' GPB0F402.375
WRITE(6,*) 'Exiting' GPB0F402.376
GOTO 999 GPB0F402.377
ENDIF GPB0F402.378
*ENDIF GPB0F402.379
GPB0F402.380
*IF DEF,OCEAN GPB0F402.381
IF ((ocn_nprocx*ocn_nprocy) .NE. nproc_max ) THEN GPB0F402.382
WRITE(6,*) 'Error : Ocean decomposition of ',ocn_nprocx, GPB0F402.383
& ' x ',ocn_nprocy,' processors cannot be supported ', GPB0F402.384
& 'using ',nproc_max,' processors.' GPB0F402.385
WRITE(6,*) 'Exiting' GPB0F402.386
GOTO 999 GPB0F402.387
ENDIF GPB0F402.388
*ENDIF GPB0F402.389
GPB0F402.390
*IF -DEF,T3D,AND,-DEF,T3E GPB0F402.391
CALL FORT_GET_ENV('PAREXE',6,parexe_env,100,err) GPB0F401.215
IF (err .NE. 0) THEN GPB0F401.216
WRITE(6,*) 'Failed to get the name of the parallel executable ', GPB0F401.217
& 'script from $PAREXE' GPB0F401.218
WRITE(6,*) '*** Model Exiting.' GPB0F401.219
GOTO 999 GPB0F401.220
ENDIF GPB0F401.221
*ELSE GPB0F402.392
parexe_env=' ' GPB0F402.393
*ENDIF GPB0F402.394
GPB0F402.395
GPB0F401.222
CALL GC_INIT(parexe_env,mype,nproc_max) GPB0F402.396
IF (nproc_max .LT. 0) THEN GPB0F402.397
WRITE(6,*) 'Parallel initialisation failed' GPB0F305.155
GOTO 999 GPB0F305.156
ELSE GPB0F305.157
APB1F402.284
! Send output to unique filename on every PE APB1F402.285
APB1F402.286
CALL FORT_GET_ENV('UM_STDOUT_FILE',14,stdout_basename,180,err) APB1F402.287
IF (err .NE. 0) THEN APB1F402.288
! Environment variable UM_STDOUT_FILE has not been set, so we will APB1F402.289
! construct a default stdout_basename of $DATAW/$RUNID.fort6.pe APB1F402.290
CALL FORT_GET_ENV('DATAW',5,dataw_char,170,err) APB1F402.291
IF (err .NE. 0) THEN APB1F402.292
WRITE(6,*) 'UMSHELL : Failed to get value of $DATAW' APB1F402.293
WRITE(6,*) '*** Model Exiting.' APB1F402.294
GOTO 999 APB1F402.295
ENDIF APB1F402.296
CALL FORT_GET_ENV('RUNID',5,runid_char,5,err) APB1F402.297
IF (err .NE. 0) THEN APB1F402.298
WRITE(6,*) 'UMSHELL : Failed to get value of $RUNID' APB1F402.299
WRITE(6,*) '*** Model Exiting.' APB1F402.300
GOTO 999 APB1F402.301
ENDIF APB1F402.302
len_dataw=GET_CHAR_LEN(dataw_char) APB1F402.303
len_runid=GET_CHAR_LEN(runid_char) APB1F402.304
stdout_basename=dataw_char(1:len_dataw)//'/'// APB1F402.305
& runid_char(1:len_runid)//'.fort6.pe' APB1F402.306
ENDIF APB1F402.307
APB1F402.308
! Now add PE number (mype) to stdout_basename to get the complete APB1F402.309
! stdout_filename for this PE. APB1F402.310
APB1F402.311
len_basename=GET_CHAR_LEN(stdout_basename) APB1F402.312
IF (mype .LT. 10) THEN APB1F402.313
WRITE(stdout_filename,'(A,I1)') APB1F402.314
& stdout_basename(1:len_basename),mype APB1F402.315
ELSEIF (mype .LT. 100) THEN APB1F402.316
WRITE(stdout_filename,'(A,I2)') APB1F402.317
& stdout_basename(1:len_basename),mype APB1F402.318
ELSEIF (mype .LT. 1000) THEN APB1F402.319
WRITE(stdout_filename,'(A,I3)') APB1F402.320
& stdout_basename(1:len_basename),mype APB1F402.321
ELSE APB1F402.322
WRITE(stdout_filename,'(A,I4)') APB1F402.323
& stdout_basename(1:len_basename),mype APB1F402.324
ENDIF APB1F402.325
APB1F402.326
! and close unit 6, then reopen to new filename APB1F402.327
APB1F402.328
CLOSE(6) APB1F402.329
OPEN(6,FILE=stdout_filename) APB1F402.330
! Force a close with a delete action - so if there is an existing GPB0F405.21
! unit6 output file it will be deleted, and the output from this GPB0F405.22
! run will go to a fresh file GPB0F405.23
CLOSE(6,STATUS='DELETE') GPB0F405.24
GPB0F405.25
OPEN(6,FILE=stdout_filename) GPB0F405.26
! Force a close with a delete action - so if there is an existing GPB1F404.139
! unit6 output file it will be deleted, and the output from this GPB1F404.140
! run will go to a fresh file GPB1F404.141
CLOSE(6,STATUS='DELETE') GPB1F404.142
GPB1F404.143
OPEN(6,FILE=stdout_filename) GPB1F404.144
APB1F402.331
WRITE(6,*) nproc_max,' Processors initialised.' GPB0F402.398
WRITE(6,*) 'I am PE ',mype GPB0F305.159
ENDIF GPB0F305.160
c GBCAF404.16
GDR3F405.5
*IF DEF,MPP GDR3F405.6
if (mype.eq.0) then GDR3F405.7
*ENDIF GDR3F405.8
call date_and_time(ch_date2, ch_time2) GDR3F405.9
write(6,*) 'Start of UM Job : ', GDR3F405.10
& ch_time2(1:2),':',ch_time2(3:4),':',ch_time2(5:6),' on ', GDR3F405.11
& ch_date2(7:8),'/',ch_date2(5:6),'/',ch_date2(1:4) GDR3F405.12
*IF DEF,MPP GDR3F405.13
endif GDR3F405.14
*ENDIF GDR3F405.15
GDR3F405.16
c See if the SHMEM/NAM Timeout value has been set in a shell GBCAF404.17
c variable. GBCAF404.18
c GBCAF404.19
call fort_get_env('UM_NAM_MAX_SECONDS', 18, c_nam_max_seconds, GBCAF404.20
& 8, err) GBCAF404.21
if (err .ne. 0) then GBCAF404.22
um_nam_max_seconds=300. GBCAF404.23
if(mype.eq.0) then GBCAF404.24
write(6,*) GBCAF404.25
& 'Warning: Environment variable UM_NAM_MAX_SECONDS ', GBCAF404.26
& 'has not been set.' GBCAF404.27
write(6,*) 'Setting UM_NAM_MAX_SECONDS to ', GBCAF404.28
& um_nam_max_seconds GBCAF404.29
*IF DEF,T3E GBCAF404.30
write(0,*) GBCAF404.31
& 'Warning: Environment variable UM_NAM_MAX_SECONDS ', GBCAF404.32
& 'has not been set.' GBCAF404.33
write(0,*) 'Setting UM_NAM_MAX_SECONDS to ', GBCAF404.34
& um_nam_max_seconds GBCAF404.35
*ENDIF GBCAF404.36
endif GBCAF404.37
else GBCAF404.38
read(c_nam_max_seconds,'(i8)') um_nam_max_seconds GBCAF404.39
if(mype.eq.0) then GBCAF404.40
write(6,*) 'Setting UM_NAM_MAX_SECONDS to ', GBCAF404.41
& um_nam_max_seconds GBCAF404.42
*IF DEF,T3E GBCAF404.43
write(0,*) 'Setting UM_NAM_MAX_SECONDS to ', GBCAF404.44
& um_nam_max_seconds GBCAF404.45
*ENDIF GBCAF404.46
endif GBCAF404.47
endif GBCAF404.48
c GBCAF404.49
c--now set the value GBCAF404.50
call gc_setopt(GC_NAM_TIMEOUT, um_nam_max_seconds, err) GBCAF404.51
if(err. ne. GC_OK) then GBCAF404.52
write(6,*)'Response from GC_SETOPT was ', err GBCAF404.53
*IF DEF,T3E GBCAF404.54
if(mype.eq.0) then GBCAF404.55
write(6,*)'Response from GC_SETOPT was ', err GBCAF404.56
endif GBCAF404.57
*ENDIF GBCAF404.58
call abort() GBCAF404.59
endif GBCAF404.60
GPB0F305.161
!---------------------------------------------------------------------- GPB0F305.162
*ENDIF GPB0F305.163
! Start timer PXUMSHEL.9
CALL TIMER('UM_SHELL',1) PXUMSHEL.10
*IF DEF,SGI PXUMSHEL.11
! Open file for UNIT 5 before initialisation of model. All runtime PXUMSHEL.12
! control variables subsequently read in from UNIT 5 by namelist. PXUMSHEL.13
CALL GET_FILE(5,FILENAME,80,ICODE) PXUMSHEL.14
OPEN(5,FILE=FILENAME,IOSTAT=ISTATUS) PXUMSHEL.15
IF(ISTATUS.NE.0) THEN PXUMSHEL.16
ICODE=500 PXUMSHEL.17
WRITE(6,*) ' ERROR OPENING FILE ON UNIT 5' PXUMSHEL.18
WRITE(6,*) ' FILENAME =',FILENAME PXUMSHEL.19
WRITE(6,*) ' IOSTAT =',ISTATUS PXUMSHEL.20
GOTO 999 PXUMSHEL.21
END IF PXUMSHEL.22
PXUMSHEL.23
CL------------------------------------------------------------------ PXUMSHEL.24
CL 0.1 Get submodel/internal model components of model run. PXUMSHEL.25
CL PXUMSHEL.26
ICODE=0 PXUMSHEL.27
CALL UM_Submodel_Init(ICODE) PXUMSHEL.28
*ENDIF PXUMSHEL.29
CL GLW2F402.96
CL Open unit 8 for server requests and send wakeup message GLW2F402.97
CL GLW2F402.98
*IF DEF,MPP GLW2F402.99
IF (mype.eq.0) THEN GLW2F402.100
CALL GET_FILE(8,FILENAME,80,ICODE) GLW2F402.101
OPEN(8,FILE=FILENAME) GLW2F402.102
WRITE(8,10) GLW2F402.103
ENDIF GLW2F402.104
10 FORMAT('** WAKEUP **') GLW2F402.105
*ELSE GLW2F402.106
CALL GET_FILE(8,FILENAME,80,ICODE) GLW2F402.107
OPEN(8,FILE=FILENAME) GLW2F402.108
WRITE(8,10) GLW2F402.109
10 FORMAT('** WAKEUP **') GLW2F402.110
*ENDIF GLW2F402.111
!---------------------------------------------------------------------- GLW2F402.112
CL 1.1 Get configuration-dependent sizes needed for dynamic allocation. UMSHELL1.61
CL UMSHELL1.62
CALL READSIZE( UMSHELL1.64
& ICODE,CMESSAGE) UMSHELL1.65
IF (ICODE.GT.0) GOTO 999 GRB1F305.704
GRB1F305.705
CL Read history and control files for NRUN; also interim control GRB1F305.706
CL file for CRUN, and housekeeping file for operational run. GRB1F305.707
CL GRB1F305.708
CALL UM_SETUP( GRB1F305.709
& ICODE,CMESSAGE) GRB1F305.710
GRB1F305.711
IF (ICODE.GT.0) GOTO 999 GRB1F305.712
CL---------------------------------------------------------------------- GRB1F305.713
UMSHELL1.66
*IF DEF,MPP GPB0F305.164
*IF DEF,ATMOS GPB0F402.399
GPB0F402.400
! Decompose atmosphere data and find new local data size GPB0F402.401
GPB0F402.402
CALL DECOMPOSE_ATMOS( ROW_LENGTH , P_ROWS, P_LEVELS , GPB0F402.403
& atm_nprocx, atm_nprocy, GPB0F402.404
& local_row_len , local_p_rows) GPB0F402.405
GPB0F402.406
! Set up the atmosphere decomposition in PARVARS GPB0F402.407
CALL CHANGE_DECOMPOSITION(decomp_standard_atmos,ICODE) GPB0F402.408
GPB0F402.409
IF (ICODE .NE. 0) GOTO 999 GPB0F402.410
GPB0F402.411
GPB0F305.169
! And replace ROW_LENGTH and P_ROWS which are currently set up GPB0F305.170
! with the global values, with the values returned from DECOMPOSE_DATA GPB0F305.171
GPB0F305.172
ROW_LENGTH = local_row_len GPB0F305.173
P_ROWS = local_p_rows GPB0F305.174
GPB0F305.175
*ENDIF GPB0F402.412
GPB0F402.413
*IF DEF,OCEAN GPB0F402.414
! Decompose ocean data and find new local data size GPB0F402.415
GPB0F402.416
CALL DECOMPOSE_OCEAN ( IMT_UI , JMT_UI , KM_UI , GPB0F402.417
& ocn_nprocx, ocn_nprocy, GPB0F402.418
& local_row_len , local_p_rows, GPB2F403.119
& CYCLIC_OCEAN) GPB2F403.120
GPB0F402.420
IMT_UI=local_row_len GPB0F402.421
JMT_UI=local_p_rows GPB0F402.422
GPB0F402.423
*IF -DEF,ATMOS GPB0F402.424
! Set up the ocean decomposition in PARVARS GPB0F402.425
CALL CHANGE_DECOMPOSITION(decomp_standard_ocean,ICODE) GPB0F402.426
*ENDIF GPB0F402.427
*ENDIF GPB0F402.428
GPB0F401.231
*ENDIF GPB0F305.176
! Call DERVSIZE (the call in READSIZE has been deleted) GPB0F305.177
GPB0F305.178
ICODE=0 GPB0F305.179
CALL DERVSIZE(ICODE,CMESSAGE) GPB0F305.180
IF (ICODE .NE. 0) GOTO 999 GPB0F305.181
GPB0F305.182
*IF DEF,ATMOS,AND,DEF,MPP GDR5F405.5
GDR5F405.6
! Ensure that domain decomposition is set for Atmosphere GDR5F405.7
call change_decomposition (decomp_standard_atmos,icode) GDR5F405.8
if (icode.ne.0) then GDR5F405.9
write (6,*) ' Error returned in CHANGE_DECOMPOSITION', GDR5F405.10
& ' before DERV_LAND_FIELD.' GDR5F405.11
write (6,*) ' Error code ',icode GDR5F405.12
write (cmessage,*) 'UM_SHELL : Error in CHANGE_DECOMPOSITION.' GDR5F405.13
go to 999 ! Exit GDR5F405.14
endif GDR5F405.15
GDR5F405.16
! For MPP jobs, calculate the no of land-points on each PE. GDR5F405.17
CALL DERV_LAND_FIELD (21,icode,cmessage) GDR5F405.18
if (icode.gt.0) then GDR5F405.19
write (6,*) 'Error returned from DERV_LAND_FIELD.' GDR5F405.20
write (6,*) 'Error code ',icode GDR5F405.21
go to 999 ! Exit GDR5F405.22
endif GDR5F405.23
GDR5F405.24
*ENDIF GDR5F405.25
*IF DEF,ATMOS GDR2F405.171
! Derive lengths involved with output boundary files - atmos. GDR2F405.172
CALL DERV_INTF_A (TOT_LEN_INTFA_P,TOT_LEN_INTFA_U, GDR2F405.173
& MAX_INTF_P_LEVELS,N_INTF_A,U_FIELD,U_FIELD_INTFA) GDR2F405.174
GDR2F405.175
*ENDIF GDR2F405.176
GDR2F405.177
C SF011193.30
*IF DEF,OCEAN GMB1F405.564
! Derive lengths involved with output boundary files - atmos. GMB1F405.565
CALL DERV_INTF_O (TOT_LEN_INTFO_P,TOT_LEN_INTFO_U, GMB1F405.566
& MAX_INTF_P_LEVELS_O,N_INTF_O) GMB1F405.567
*ENDIF GMB1F405.568
C Copy NAMELIST values of OCEAN variables into main variables SF011193.31
C becuase portable model cannot use dynamic allocation for arrays SF011193.32
C whose dimensions are in COMMON SF011193.33
C SF011193.34
NT=NT_UI SF011193.35
IMT=IMT_UI SF011193.36
JMT=JMT_UI SF011193.37
KM=KM_UI SF011193.38
IF (ICODE.GT.0) GOTO 999 UMSHELL1.67
!----------------------------------------------------------------------- GSS1F305.868
! 1.2 Call STASH_PROC: top level control routine for processing of GSS1F305.869
! STASH requests and STASH addressing. GSS1F305.870
GSS1F305.871
! Open STASHmaster file(s) and count number of records GSS2F401.472
! This number is assigned to ppxRecs and used to dynamically GSS2F401.473
! allocate the PPX_ arrays in which stash master records are held GSS2F401.474
ppxRecs = 1 GSS2F401.475
ICODE = 0 GSS2F401.476
IF (INTERNAL_MODEL_INDEX(A_IM).GT.0) GSS2F401.477
& CALL HDPPXRF GSS2F401.478
&(NFTPPXREF,'STASHmaster_A',ppxRecs,ICODE,CMESSAGE) GSS2F401.479
IF (ICODE.NE.0) GO TO 999 GBCKF405.3
IF (INTERNAL_MODEL_INDEX(O_IM).GT.0) GSS2F401.480
& CALL HDPPXRF GSS2F401.481
&(NFTPPXREF,'STASHmaster_O',ppxRecs,ICODE,CMESSAGE) GSS2F401.482
IF (ICODE.NE.0) GO TO 999 GBCKF405.4
IF (INTERNAL_MODEL_INDEX(S_IM).GT.0) GSS2F401.483
& CALL HDPPXRF GSS2F401.484
&(NFTPPXREF,'STASHmaster_S',ppxRecs,ICODE,CMESSAGE) GSS2F401.485
IF (ICODE.NE.0) GO TO 999 GBCKF405.5
IF (INTERNAL_MODEL_INDEX(W_IM).GT.0) GSS2F401.486
& CALL HDPPXRF GSS2F401.487
&(NFTPPXREF,'STASHmaster_W',ppxRecs,ICODE,CMESSAGE) GSS2F401.488
IF (ICODE.NE.0) GO TO 999 GBCKF405.6
! Add number of user stash records GSS2F401.489
CALL HDPPXRF(0,' ',ppxRecs,ICODE,CMESSAGE) GSS2F401.490
GSS1F305.874
IF (icode .lt. 0) then GDW1F404.108
*IF DEF,MPP GDW1F404.109
IF (mype .eq. 0) then GDW1F404.110
write (0,*) 'WARNING : Problem in STASHmaster file(s)' GDW1F404.111
write (0,*) ' ',cmessage(1:get_char_len(cmessage)) GBC1F405.35
END IF GDW1F404.113
*ELSE GDW1F404.114
write (0,*) 'WARNING : Problem in STASHmaster file(s)' GDW1F404.115
write (0,*) ' ',cmessage(1:get_char_len(cmessage)) GBC1F405.36
*ENDIF GDW1F404.117
ELSE IF (icode .gt. 0) then GDW1F404.118
*IF DEF,MPP GDW1F404.119
IF (mype .eq. 0) then GDW1F404.120
write (0,*) 'ERROR : Problem in STASHmaster files(s)' GDW1F404.121
write (0,*) ' ',cmessage(1:get_char_len(cmessage)) GBC1F405.37
END IF GDW1F404.123
*ELSE GDW1F404.124
write (0,*) 'ERROR : Problem in STASHmaster files(s)' GDW1F404.125
write (0,*) ' ',cmessage(1:get_char_len(cmessage)) GBC1F405.38
*ENDIF GDW1F404.127
goto 999 ! Always abort on fatal error. GDW1F404.128
END IF GDW1F404.129
GSS1F305.877
CALL STASH_PROC(NFTPPXREF,NFTSTMSTU,.FALSE., GSS1F305.878
& ppxRecs,ICODE,CMESSAGE ) GSS1F400.729
IF (ICODE.GT.0) GOTO 999 GSS1F305.880
GSS1F305.881
! Total number of entries (N_PPXRECS) in STASH-addresses array IN_S has GSS1F305.882
! obtained by WSTLST in STASH_PROC. Reset ppxRecs to equal this value. GSS1F400.730
! This is used to dynamically GSS1F400.731
! allocate the ppx look-up arrays PPXI, PPXC in U_MODEL. GSS1F400.732
GSS1F305.886
ppxRecs = N_PPXRECS GSS1F400.733
GSS1F305.888
CL---------------------------------------------------------------------- UMSHELL1.68
CL 1.3 Calculate addresses of super arrays passed down for dynamic GSS1F305.889
CL allocation. UMSHELL1.70
CL UMSHELL1.71
ICODE=0 UMSHELL1.72
CALL UM_INDEX( UMSHELL1.73
*CALL ARGSIZE SF011193.39
*CALL ARGSZSP UMSHELL1.74
*CALL ARGSZSPA UMSHELL1.75
*CALL ARGSZSPO UMSHELL1.76
*CALL ARGSZSPW WRB1F401.1119
*CALL ARGSZSPC UMSHELL1.77
& ICODE,CMESSAGE) UMSHELL1.78
UMSHELL1.79
IF (ICODE.GT.0) GOTO 999 UMSHELL1.80
CL---------------------------------------------------------------------- UMSHELL1.81
CL 2. Call U_MODEL master routine to allocate the main data arrays UMSHELL1.82
CL and do the calculations. UMSHELL1.83
CL UMSHELL1.84
CALL U_MODEL ( UMSHELL1.85
& NFTPPXREF,NFTSTMSTU, GSS2F401.491
*CALL ARGSZSP UMSHELL1.86
*CALL ARGSZSPA UMSHELL1.87
*CALL ARGSZSPO UMSHELL1.88
*CALL ARGSZSPW WRB1F401.1120
*CALL ARGSZSPC UMSHELL1.89
*CALL ARGSIZE UMSHELL1.90
& P_FIELD_CONV, ! copies for portability of dynamic allocation RB300993.153
& Q_LEVELS, ! of convective increment storage arrays. RB300993.154
*IF DEF,FRADIO GGH3F401.36
& P_FIELD,P_LEVELS, ! copies for portability of dynamic allocation UMSHELL1.92
*ENDIF UMSHELL1.93
& ppxRecs,ICODE,CMESSAGE) GSS1F400.734
C UMSHELL1.95
999 CONTINUE UMSHELL1.96
CLOSE(5) GPB0F305.16
CL---------------------------------------------------------------------- UMSHELL1.97
CL 3. Exit processing: Call ABORT if non-zero completion code. UMSHELL1.98
CL UMSHELL1.99
CALL TIMER('UM_SHELL',2) GSM1F401.25
IF (iCode .ne. 0) then GDW1F404.130
*IF DEF,MPP GDW1F404.131
IF (mype .eq. 0) then GDW1F404.132
*ENDIF GDW1F404.133
write (0,*) '*****************************************' GDW1F404.134
write (0,*) '*****************************************' GDW1F404.135
write (0,*) 'Model completed with the following :' GDW1F404.136
write (0,*) ' Error Code : ', iCode GDW1F404.137
write (0,*) ' Message : ', GBC1F405.39
& cMessage(1:get_char_len(cmessage)) GBC1F405.40
write (0,*) '*****************************************' GDW1F404.139
write (0,*) '*****************************************' GDW1F404.140
*IF DEF,MPP GDW1F404.141
ENDIF GDW1F404.142
*ENDIF GDW1F404.143
ENDIF GDW1F404.144
IF (ICODE.GT.0) CALL ABORT UMSHELL1.101
*IF DEF,MPP GPB0F305.189
! Close down parallel process communication GPB0F305.190
CALL GC_EXIT() GPB0F305.191
GPB0F305.192
WRITE(6,*) 'Process ',mype,' has exited.' GPB0F305.193
*ENDIF GPB0F305.194
*IF DEF,CRI_FFIO GBC0F403.75
call barrier() GBC0F403.76
close_time=secondr() GBC0F403.77
call close_all_files() GBC0F403.78
call barrier() GBC0F403.79
close_time=secondr()-close_time GBC0F403.80
*IF DEF,MPP GBC0F403.81
if(mype.eq.0) write(0,9976) close_time GBC0F403.82
if(mype.eq.0) write(6,9976) close_time GBC0F403.83
*ELSE GBC0F403.84
write(6,9976) close_time GBC0F403.85
*ENDIF GBC0F403.86
9976 format(/'Time to Close All Files was ',f7.3,' Seconds'/) GBC0F403.87
*ENDIF GBC0F403.88
C UMSHELL1.102
*IF DEF,MPP GDR3F405.17
if (mype.eq.0) then GDR3F405.18
*ENDIF GDR3F405.19
call date_and_time(ch_date2, ch_time2) GDR3F405.20
write(6,*) 'End of UM Job : ', GDR3F405.21
& ch_time2(1:2),':',ch_time2(3:4),':',ch_time2(5:6),' on ', GDR3F405.22
& ch_date2(7:8),'/',ch_date2(5:6),'/',ch_date2(1:4) GDR3F405.23
*IF DEF,MPP GDR3F405.24
endif GDR3F405.25
*ENDIF GDR3F405.26
GDR3F405.27
STOP UMSHELL1.103
END UMSHELL1.104
*ENDIF UMSHELL1.105