SUBROUTINE OUTPTL( 1,9OUTPTL1.7
*CALL ARGPPX 
OUTPTL1.8
& NRECS,ErrorStatus,CMESSAGE) OUTPTL1.9
IMPLICIT NONE OUTPTL1.10
OUTPTL1.11
! Description: OUTPTL1.12
! OUTPTL1.13
! Method: OUTPTL1.14
! OUTPTL1.15
! Current code owner: S.J.Swarbrick OUTPTL1.16
! OUTPTL1.17
! History: OUTPTL1.18
! Version Date Comment OUTPTL1.19
! ======= ==== ======= OUTPTL1.20
! 3.5 Apr. 95 Original code. S.J.Swarbrick OUTPTL1.21
! 4.1 Apr. 96 Inclusion of wave model. S.J.Swarbrick GSS3F401.763
! 4.2 03/09/96 MPP code : Made addressing local - a processor GPB1F402.458
! only holds data in its geographical area. GPB1F402.459
! P. Burton GPB1F402.460
! 4.3 13/03/97 MPP fixes P.Burton GPB0F403.3076
!LL 4.4 22/11/96 Altered for new case of daily mean timeseries GRS1F404.130
! R A Stratton. GRS1F404.131
! 4.4 12/06/97 Corrected code for global wrap around P.Burton GPB0F404.63
! 4.5 03/09/98 Don't set the decomposition for the SCH0F405.20
! slab model. Prior to this there would be an SCH0F405.21
! error message if the slab model was selected SCH0F405.22
! for mpp runs. Slab model can now be run with SCH0F405.23
! mpp selected. C. D. Hewitt SCH0F405.24
! 4.5 23/01/98 Set up st_dump_level_output_length. P.Burton GPB2F405.150
! OUTPTL1.22
! Code description: OUTPTL1.23
! FORTRAN 77 + common Fortran 90 extensions. OUTPTL1.24
! Written to UM programming standards version 7. OUTPTL1.25
! OUTPTL1.26
! System component covered: OUTPTL1.27
! System task: Sub-Models Project OUTPTL1.28
! OUTPTL1.29
! Global variables: OUTPTL1.30
*CALL CSUBMODL OUTPTL1.32
*CALL CPPXREF GSS3F401.764
*CALL PPXLOOK GSS3F401.765
*CALL CSTASH GRB0F401.7
*CALL STEXTEND OUTPTL1.35
*CALL STPARAM OUTPTL1.36
*IF DEF,MPP OUTPTL1.39
*CALL PARVARS OUTPTL1.40
*CALL DECOMPTP GPB1F402.461
*ENDIF OUTPTL1.41
OUTPTL1.42
! Subroutine arguments OUTPTL1.43
! Array arguments with intent(in): OUTPTL1.45
INTEGER NRECS OUTPTL1.46
OUTPTL1.47
! Array arguments with intent(out): OUTPTL1.48
CHARACTER*80 CMESSAGE OUTPTL1.49
OUTPTL1.50
! ErrorStatus: OUTPTL1.51
INTEGER ErrorStatus OUTPTL1.52
OUTPTL1.53
! Local variables OUTPTL1.54
INTEGER output_length OUTPTL1.56
INTEGER IE OUTPTL1.57
INTEGER IN OUTPTL1.58
INTEGER IP_DIM OUTPTL1.59
INTEGER IREC OUTPTL1.60
INTEGER IS OUTPTL1.61
INTEGER MODL OUTPTL1.62
INTEGER ISEC OUTPTL1.63
INTEGER ITEM OUTPTL1.64
INTEGER IT_DIM OUTPTL1.65
INTEGER IW OUTPTL1.66
INTEGER IX_DIM OUTPTL1.67
INTEGER IY_DIM OUTPTL1.68
INTEGER IZ_DIM OUTPTL1.69
*IF DEF,MPP GPB1F402.462
INTEGER GPB1F402.463
! local versions of the global subdomain boundaries GPB1F402.464
& local_north,local_east,local_south,local_west GPB1F402.465
&, local_IN,local_IE,local_IS,local_IW GPB1F402.466
! global versions of the X and Y horizontal dimensions, and GPB1F402.467
! total output size GPB1F402.468
&, global_IX_DIM,global_IY_DIM,global_output_length GPB1F402.469
! variables indicating the decomposition type at various stages GPB1F402.470
&, orig_decomp,decomp_type GPB1F402.471
*ENDIF GPB1F402.472
OUTPTL1.70
! Function and subroutine calls: OUTPTL1.71
INTEGER EXPPXI OUTPTL1.73
EXTERNAL EXPPXI,LLTORC OUTPTL1.74
OUTPTL1.75
!- End of Header -------------------------------------------------- OUTPTL1.76
OUTPTL1.77
*IF DEF,MPP GPB1F402.473
orig_decomp=current_decomp_type GPB1F402.474
*ENDIF GPB1F402.475
GPB1F402.476
! Loop over STASH records OUTPTL1.78
DO IREC=1,NRECS OUTPTL1.80
OUTPTL1.81
! Obtain model, section, item for this record OUTPTL1.82
MODL = LIST_S(st_model_code ,IREC) OUTPTL1.84
ISEC = LIST_S(st_sect_no_code,IREC) OUTPTL1.85
ITEM = LIST_S(st_item_code ,IREC) OUTPTL1.86
GPB1F402.477
*IF DEF,MPP GPB1F402.478
! Set the correct decomposition type for this model GPB1F402.479
IF (MODL .EQ. ATMOS_IM) THEN GPB1F402.480
decomp_type=decomp_standard_atmos GPB1F402.481
ELSEIF (MODL .EQ. OCEAN_IM) THEN GPB1F402.482
decomp_type=decomp_nowrap_ocean GPB0F403.3077
ELSEIF (MODL. EQ. SLAB_IM) THEN SCH0F405.25
WRITE(6,*) 'OUTPTL1 : Slab model not actually running MPP', SCH0F405.26
& ' but will run on PE0 while atmosphere runs MPP' SCH0F405.27
ELSE GPB1F402.484
! Shouldn't get to this GPB1F402.485
decomp_type=decomp_unset GPB1F402.486
WRITE(6,*) 'OUTPTL : Error' GPB1F402.487
WRITE(6,*) 'Unsupported Model ',MODL,' for MPP code' GPB1F402.488
CMESSAGE='Unsupported Model for MPP code' GPB1F402.489
ErrorStatus=-1 GPB1F402.490
GOTO 999 GPB1F402.491
ENDIF GPB1F402.492
GPB1F402.493
IF (current_decomp_type .NE. decomp_type) THEN GPB1F402.494
CALL CHANGE_DECOMPOSITION(decomp_type,ErrorStatus) GPB1F402.495
IF (ErrorStatus .NE. 0) THEN GPB1F402.496
WRITE(6,*) 'OUTPUTL : Error' GPB1F402.497
WRITE(6,*) 'Call to CHANGE_DECOMPOSITION failed with ', GPB1F402.498
& 'decomposition type ',decomp_type GPB1F402.499
CMESSAGE='Unsupported decomposition for MPP code' GPB1F402.500
GOTO 999 GPB1F402.501
ENDIF GPB1F402.502
ENDIF GPB1F402.503
*ENDIF GPB1F402.504
GPB1F402.505
OUTPTL1.87
! Extract level code, grid type code from ppx lookup array OUTPTL1.88
ILEV = EXPPXI(MODL,ISEC,ITEM,ppx_lv_code, OUTPTL1.90
*CALL ARGPPX OUTPTL1.91
& ErrorStatus,CMESSAGE) OUTPTL1.92
IGP = EXPPXI(MODL,ISEC,ITEM,ppx_grid_type, OUTPTL1.93
*CALL ARGPPX OUTPTL1.94
& ErrorStatus,CMESSAGE) OUTPTL1.95
IPSEUDO = EXPPXI(MODL ,ISEC ,ITEM,ppx_pt_code , GSS3F401.766
*CALL ARGPPX ORH5F400.22
& ErrorStatus,CMESSAGE) GSS3F401.767
IF (LIST_S(st_proc_no_code,IREC).EQ.0) THEN OUTPTL1.97
! Dummy record - output length zero GSS3F401.768
LIST_S(st_output_length,IREC)=0 OUTPTL1.99
*IF -DEF,MPP GPB0F403.3078
ELSE IF(LIST_S(st_input_code,IREC).LT.0.and. GRS1F404.132
& LIST_S(st_proc_no_code,IREC).ne.8) THEN GRS1F404.133
GRS1F404.134
*ELSE GPB0F403.3079
ELSE IF(LIST_S(st_input_code,IREC).LT.0.and. GRS1F404.135
& LIST_S(st_proc_no_code,IREC).ne.8.and. GRS1F404.136
& (LIST_S(st_output_code,IREC) .NE. -89)) THEN GPB0F403.3081
! Only copy parent's length for non MOS data. MOS data is GPB0F403.3082
! stored as a global field, so is longer than the parent data GPB0F403.3083
! which is distributed across fields GPB0F403.3084
*ENDIF GPB0F403.3085
! Child record - get output length from parent GSS3F401.769
LIST_S(st_output_length,IREC)= OUTPTL1.103
& LIST_S(st_output_length,-LIST_S(st_input_code,IREC)) OUTPTL1.104
GRS1F404.137
ELSE OUTPTL1.106
! Neither dummy nor child - calculate output length OUTPTL1.108
! T dimension (equals 1 except for the time series case) GSS3F401.770
IF((LIST_S(st_proc_no_code,IREC).EQ.1).OR. OUTPTL1.112
& (LIST_S(st_proc_no_code,IREC).EQ.2).OR. OUTPTL1.113
& (LIST_S(st_proc_no_code,IREC).EQ.3).OR. OUTPTL1.114
& (LIST_S(st_proc_no_code,IREC).EQ.5).OR. OUTPTL1.115
& (LIST_S(st_proc_no_code,IREC).EQ.6)) THEN OUTPTL1.116
IT_DIM=1 OUTPTL1.118
ELSE IF (LIST_S(st_proc_no_code,IREC).EQ.4.or. GRS1F404.138
& LIST_S(st_proc_no_code,IREC).EQ.8) THEN GRS1F404.139
! Time series case GSS3F401.771
IT_DIM= OUTPTL1.122
& LIST_S(st_period_code,IREC)/LIST_S(st_freq_code,IREC) OUTPTL1.123
GRS1F404.140
ELSE GSS3F401.772
WRITE(6,*)'OUTPTL: ERROR UNEXPECTED PROCESSING CODE', OUTPTL1.127
& LIST_S(st_proc_no_code,IREC),' FOR RECORD ',IREC OUTPTL1.128
END IF OUTPTL1.131
OUTPTL1.132
IF( LIST_S(st_series_ptr,IREC).EQ.0) THEN OUTPTL1.133
*IF DEF,MPP GPB1F402.506
! Set up local versions of the boundaries of the subdomain GPB1F402.507
GPB1F402.508
CALL GLOBAL_TO_LOCAL_SUBDOMAIN( .TRUE., .TRUE., GPB1F402.509
& IGP,mype, GPB1F402.510
& LIST_S(st_north_code,IREC), GPB1F402.511
& LIST_S(st_east_code,IREC), GPB1F402.512
& LIST_S(st_south_code,IREC), GPB1F402.513
& LIST_S(st_west_code,IREC), GPB1F402.514
& local_north,local_east, GPB1F402.515
& local_south,local_west) GPB1F402.516
*ENDIF GPB1F402.517
GPB1F402.518
! Not a time series profile OUTPTL1.135
! X dimension OUTPTL1.137
IF(LIST_S(st_gridpoint_code,IREC).LT.0) THEN GSS3F401.773
WRITE(6,*)'OUTPTL: ERROR UNEXPECTED GRIDPOINT CODE', OUTPTL1.141
& LIST_S(st_gridpoint_code,IREC),' FOR RECORD ',IREC OUTPTL1.142
ELSE IF(LIST_S(st_gridpoint_code,IREC).LT.20) THEN GSS3F401.774
*IF -DEF,MPP GPB1F402.519
IX_DIM=LIST_S(st_east_code,IREC)- OUTPTL1.147
& LIST_S(st_west_code,IREC)+1 OUTPTL1.148
*ELSE GPB1F402.520
IX_DIM=local_east-local_west+1 GPB1F402.521
global_IX_DIM=LIST_S(st_east_code,IREC)- GPB1F402.522
& LIST_S(st_west_code,IREC)+1 GPB1F402.523
*ENDIF GPB1F402.524
ELSE IF(LIST_S(st_gridpoint_code,IREC).LT.30) THEN OUTPTL1.150
IX_DIM=1 OUTPTL1.152
*IF DEF,MPP GPB1F402.525
global_IX_DIM=1 GPB1F402.526
*ENDIF GPB1F402.527
ELSE IF(LIST_S(st_gridpoint_code,IREC).LT.40) THEN GSS3F401.775
*IF -DEF,MPP GPB1F402.528
IX_DIM=LIST_S(st_east_code,IREC)- OUTPTL1.156
& LIST_S(st_west_code,IREC)+1 OUTPTL1.157
*ELSE GPB1F402.529
IX_DIM=local_east-local_west+1 GPB1F402.530
global_IX_DIM=LIST_S(st_east_code,IREC)- GPB1F402.531
& LIST_S(st_west_code,IREC)+1 GPB1F402.532
*ENDIF GPB1F402.533
ELSE IF(LIST_S(st_gridpoint_code,IREC).LE.43) THEN OUTPTL1.159
IX_DIM=1 OUTPTL1.161
*IF DEF,MPP GPB1F402.534
global_IX_DIM=1 GPB1F402.535
*ENDIF GPB1F402.536
ELSE GSS3F401.776
WRITE(6,*)'OUTPTL: ERROR UNEXPECTED GRIDPOINT CODE', OUTPTL1.165
& LIST_S(st_gridpoint_code,IREC),' FOR RECORD ',IREC OUTPTL1.166
END IF ! X dim OUTPTL1.169
OUTPTL1.170
IF(IX_DIM.LT.1) THEN GSS3F401.777
! Area cut by global model GSS3F401.778
CALL LLTORC(IGP,90,-90,0,360,IN,IS,IW,IE) OUTPTL1.173
*IF -DEF,MPP GPB1F402.537
IX_DIM=IX_DIM+IE OUTPTL1.174
*ELSE GPB1F402.538
CALL GLOBAL_TO_LOCAL_SUBDOMAIN( GPB1F402.539
& .TRUE. , .TRUE. , IGP , mype , GPB1F402.540
& IN,IE,IS,IW, GPB1F402.541
& local_IN,local_IE,local_IS,local_IW) GPB1F402.542
IX_DIM=IX_DIM+local_IE-2*Offx GPB0F403.3086
! Subtract two halos, because we don't want wrap around to include GPB0F403.3087
! the halo at the end, and the beginning of field GPB0F403.3088
*ENDIF GPB1F402.545
GPB1F402.546
END IF OUTPTL1.176
*IF DEF,MPP GPB0F404.64
IF (global_IX_DIM.LT.1) THEN GPB0F404.65
CALL LLTORC(IGP,90,-90,0,360,IN,IS,IW,IE) GPB0F404.66
global_IX_DIM=global_IX_DIM+IE GPB0F404.67
ENDIF GPB0F404.68
*ENDIF GPB0F404.69
OUTPTL1.177
! Y dimension OUTPTL1.178
IF(LIST_S(st_gridpoint_code,IREC).LT.0) THEN GSS3F401.779
WRITE(6,*)'OUTPTL: ERROR UNEXPECTED GRIDPOINT CODE', OUTPTL1.182
& LIST_S(st_gridpoint_code,IREC),' FOR RECORD ',IREC OUTPTL1.183
ELSE IF(LIST_S(st_gridpoint_code,IREC).LT.30) THEN GSS3F401.780
IF (IGP.GE.60.AND.IGP.LT.70) THEN GSS3F401.781
! Wave model grid - first lat is southern most GSS3F401.782
*IF -DEF,MPP GPB1F402.547
IY_DIM=LIST_S(st_north_code,IREC)- GSS3F401.783
& LIST_S(st_south_code,IREC)+1 GSS3F401.784
*ELSE GPB1F402.548
IY_DIM=local_north-local_south+1 GPB1F402.549
global_IY_DIM=LIST_S(st_north_code,IREC)- GPB1F402.550
& LIST_S(st_south_code,IREC)+1 GPB1F402.551
*ENDIF GPB1F402.552
ELSE GSS3F401.785
! Atmos grid - first lat is northern most GSS3F401.786
*IF -DEF,MPP GPB1F402.553
IY_DIM=LIST_S(st_south_code,IREC)- GSS3F401.787
& LIST_S(st_north_code,IREC)+1 GSS3F401.788
*ELSE GPB1F402.554
IY_DIM=local_south-local_north+1 GPB1F402.555
global_IY_DIM=LIST_S(st_south_code,IREC)- GPB1F402.556
& LIST_S(st_north_code,IREC)+1 GPB1F402.557
*ENDIF GPB1F402.558
END IF GSS3F401.789
ELSE IF(LIST_S(st_gridpoint_code,IREC).LE.40) THEN OUTPTL1.196
IY_DIM=1 OUTPTL1.198
*IF DEF,MPP GPB1F402.559
global_IY_DIM=1 GPB1F402.560
*ENDIF GPB1F402.561
ELSE IF(LIST_S(st_gridpoint_code,IREC).LE.43) THEN OUTPTL1.200
IY_DIM=1 OUTPTL1.202
*IF DEF,MPP GPB1F402.562
global_IY_DIM=1 GPB1F402.563
*ENDIF GPB1F402.564
ELSE GSS3F401.790
WRITE(6,*)'OUTPTL: ERROR UNEXPECTED GRIDPOINT CODE', OUTPTL1.206
& LIST_S(st_gridpoint_code,IREC),' FOR RECORD ',IREC OUTPTL1.207
END IF ! Y dim OUTPTL1.210
OUTPTL1.211
! Z dimension OUTPTL1.212
IF(LIST_S(st_gridpoint_code,IREC).LT.0) THEN GSS3F401.791
WRITE(6,*)'OUTPTL: ERROR UNEXPECTED GRIDPOINT CODE', OUTPTL1.216
& LIST_S(st_gridpoint_code,IREC),' FOR RECORD ',IREC OUTPTL1.217
ELSE IF(LIST_S(st_gridpoint_code,IREC).LT.10) THEN GSS3F401.792
IF(ILEV.EQ.5) THEN OUTPTL1.222
IZ_DIM=1 OUTPTL1.223
ELSE IF(LIST_S(st_output_bottom,IREC).LT.0) THEN OUTPTL1.224
IZ_DIM=LEVLST_S(1,-LIST_S(st_output_bottom,IREC)) OUTPTL1.225
ELSE OUTPTL1.226
IZ_DIM=LIST_S(st_output_top,IREC)- OUTPTL1.227
& LIST_S(st_output_bottom,IREC)+1 OUTPTL1.228
END IF OUTPTL1.229
ELSE IF(LIST_S(st_gridpoint_code,IREC).LT.20) THEN OUTPTL1.231
IZ_DIM=1 OUTPTL1.233
ELSE IF(LIST_S(st_gridpoint_code,IREC).LE.43) THEN GSS3F401.793
IF(ILEV.EQ.5) THEN OUTPTL1.237
IZ_DIM=1 OUTPTL1.238
ELSE IF(LIST_S(st_output_bottom,IREC).LT.0) THEN OUTPTL1.239
IZ_DIM=LEVLST_S(1,-LIST_S(st_output_bottom,IREC)) OUTPTL1.240
ELSE OUTPTL1.241
IZ_DIM=LIST_S(st_output_top,IREC)- OUTPTL1.242
& LIST_S(st_output_bottom,IREC)+1 OUTPTL1.243
END IF OUTPTL1.244
ELSE GSS3F401.794
WRITE(6,*)'OUTPTL: ERROR UNEXPECTED GRIDPOINT CODE', OUTPTL1.248
& LIST_S(st_gridpoint_code,IREC),' FOR RECORD ',IREC OUTPTL1.249
END IF ! Z dim OUTPTL1.252
OUTPTL1.253
! P dimension - pseudo levels OUTPTL1.254
IF(IPSEUDO.GT.0) THEN OUTPTL1.256
IP_DIM=LENPLST(LIST_S(st_pseudo_out,IREC)) OUTPTL1.257
ELSE OUTPTL1.258
IP_DIM=1 OUTPTL1.259
END IF OUTPTL1.260
OUTPTL1.261
! Output length - total number of points OUTPTL1.262
*IF -DEF,MPP GPB0F403.3089
output_length = IT_DIM*IX_DIM*IY_DIM*IZ_DIM*IP_DIM OUTPTL1.265
*ELSE GPB0F403.3090
IF (LIST_S(st_output_code,IREC) .EQ. -89) THEN GPB0F403.3091
! this is MOS data GPB0F403.3092
! output_length = IT_DIM*global_IX_DIM*global_IY_DIM* GPB0F403.3093
! & IZ_DIM*IP_DIM GPB0F403.3094
! The previous two lines replaced by the following - as this GPB0F403.3095
! size is just used to dimension work arrays in stwork which GPB0F403.3096
! deal with the field level by level. This makes the work array GPB0F403.3097
! considerably smaller. GPB0F403.3098
GPB0F403.3099
output_length = IT_DIM*global_IX_DIM*global_IY_DIM* GPB0F403.3100
& IP_DIM GPB0F403.3101
GPB0F403.3102
ELSE GPB0F403.3103
output_length = IT_DIM*IX_DIM*IY_DIM*IZ_DIM*IP_DIM GPB0F403.3104
ENDIF GPB0F403.3105
GPB0F403.3106
global_output_length = GPB1F402.566
& IT_DIM*global_IX_DIM*global_IY_DIM*IZ_DIM*IP_DIM GPB1F402.567
*ENDIF GPB1F402.568
LIST_S(st_output_length,IREC) = output_length OUTPTL1.275
*IF DEF,MPP GPB1F402.569
LIST_S(st_dump_output_length,IREC) = GPB1F402.570
& global_output_length GPB1F402.571
LIST_S(st_dump_level_output_length,IREC) = GPB2F405.151
& global_IX_DIM*global_IY_DIM ! size of horizontal field GPB2F405.152
*ENDIF GPB1F402.572
ELSE ! Time series profile GSS3F401.795
LIST_S(st_output_length,IREC)= OUTPTL1.279
& NRECS_TS(LIST_S(st_series_ptr,IREC))*IT_DIM+ OUTPTL1.280
& (NRECS_TS(LIST_S(st_series_ptr,IREC))+1)*6 OUTPTL1.281
GRS1F404.141
*IF DEF,MPP GPB0F403.3107
LIST_S(st_dump_output_length,IREC)= GPB0F403.3108
& LIST_S(st_output_length,IREC) GPB0F403.3109
*ENDIF GPB0F403.3110
END IF OUTPTL1.283
END IF ! Neither dummy nor child GSS3F401.796
END DO ! Loop over STASH records OUTPTL1.287
*IF DEF,MPP GPB1F402.573
IF ((orig_decomp .NE. current_decomp_type) .AND. GPB1F402.574
& (orig_decomp .NE. decomp_unset)) THEN GPB1F402.575
CALL CHANGE_DECOMPOSITION(orig_decomp,ErrorStatus) GPB1F402.576
ENDIF GPB1F402.577
*ENDIF GPB1F402.578
OUTPTL1.288
999 RETURN OUTPTL1.289
END OUTPTL1.290
OUTPTL1.291
!- End of subroutine code ------------------------------------------- OUTPTL1.292
*ENDIF OUTPTL1.293