*IF DEF,C96_1A,OR,DEF,C96_1B GPB3F403.269
*IF DEF,MPP GPB3F403.270
C *****************************COPYRIGHT****************************** CPYFLD1A.3
C (c) CROWN COPYRIGHT 1996, METEOROLOGICAL OFFICE, All Rights Reserved. CPYFLD1A.4
C CPYFLD1A.5
C Use, duplication or disclosure of this code is subject to the CPYFLD1A.6
C restrictions as set forth in the contract. CPYFLD1A.7
C CPYFLD1A.8
C Meteorological Office CPYFLD1A.9
C London Road CPYFLD1A.10
C BRACKNELL CPYFLD1A.11
C Berkshire UK CPYFLD1A.12
C RG12 2SZ CPYFLD1A.13
C CPYFLD1A.14
C If no contract has been raised with this copy of the code, the use, CPYFLD1A.15
C duplication or disclosure of it is strictly prohibited. Permission CPYFLD1A.16
C to do so must first be obtained in writing from the Head of Numerical CPYFLD1A.17
C Modelling at the above address. CPYFLD1A.18
C ******************************COPYRIGHT****************************** CPYFLD1A.19
!+ Parallel UM: Copies one field to another, possibly with different CPYFLD1A.20
! halo sizes CPYFLD1A.21
! CPYFLD1A.22
! Subroutine interface: CPYFLD1A.23
SUBROUTINE COPY_FIELD(ORIG_FIELD,DEST_FIELD, 44,1CPYFLD1A.24
& ORIG_FIELD_SIZE,DEST_FIELD_SIZE, CPYFLD1A.25
& ORIG_ROW_LENGTH,ORIG_N_ROWS,LEVELS, CPYFLD1A.26
& ORIG_Offx,ORIG_Offy, CPYFLD1A.27
& DEST_Offx,DEST_Offy, CPYFLD1A.28
& L_SWAP) CPYFLD1A.29
CPYFLD1A.30
IMPLICIT NONE CPYFLD1A.31
! CPYFLD1A.32
! Description: CPYFLD1A.33
! This routine copies one field into another, allowing for a CPYFLD1A.34
! different halo size in the two fields. If L_SWAP is true CPYFLD1A.35
! it will update the halos on the destination field CPYFLD1A.36
! CPYFLD1A.37
! Method CPYFLD1A.38
! Data is copied from ORIG_FIELD to DEST_FIELD with the Offx and CPYFLD1A.39
! Offy values of each field taken into account to work out the offsets. CPYFLD1A.40
! Data will be copied from the halo areas of ORIG_FIELD into CPYFLD1A.41
! corresponding halo areas of DEST_FIELD. CPYFLD1A.42
! A call to SWAPBOUNDS will update the halos if L_SWAP is .TRUE. CPYFLD1A.43
! CPYFLD1A.44
! Current Code Owner : Paul Burton CPYFLD1A.45
! CPYFLD1A.46
! History: CPYFLD1A.47
! Model Date Modification history from model version 4.1 CPYFLD1A.48
! version CPYFLD1A.49
! 4.1 23/11/95 New DECK created for the Parallel Unified CPYFLD1A.50
! Model. P.Burton CPYFLD1A.51
! 4.3 25/07/97 Remove initialisation of Dest_Field AAD2F404.302
! if L_SWAP is true D.Salmond AAD2F404.303
! CPYFLD1A.52
! Subroutine Arguments: CPYFLD1A.53
CPYFLD1A.54
INTEGER ORIG_FIELD_SIZE, ! IN horizontal size of ORIG_FIELD CPYFLD1A.55
& DEST_FIELD_SIZE, ! IN horizontal size of DEST_FIELD CPYFLD1A.56
& ORIG_ROW_LENGTH, ! IN row length of ORIG_FIELD CPYFLD1A.57
& ORIG_N_ROWS, ! IN number of rows in ORIG_FIELD CPYFLD1A.58
& LEVELS, ! IN number of levels in both fields CPYFLD1A.59
& ORIG_Offx, ! IN halo size of ORIG in X direction CPYFLD1A.60
& ORIG_Offy, ! IN halo size of ORIG in Y direction CPYFLD1A.61
& DEST_Offx, ! IN halo size of DEST in X direction CPYFLD1A.62
& DEST_Offy ! IN halo size of DEST in Y direction CPYFLD1A.63
CPYFLD1A.64
LOGICAL L_SWAP ! IN do a halo swap of DEST_FIELD? CPYFLD1A.65
CPYFLD1A.66
REAL ORIG_FIELD(ORIG_FIELD_SIZE,LEVELS), CPYFLD1A.67
& ! IN Field to copy from CPYFLD1A.68
& DEST_FIELD(DEST_FIELD_SIZE,LEVELS) CPYFLD1A.69
& ! OUT Field to copy to CPYFLD1A.70
CPYFLD1A.71
! Local variables CPYFLD1A.72
CPYFLD1A.73
INTEGER DEST_ROW_LENGTH, ! row length of DEST_FIELD CPYFLD1A.74
& DEST_N_ROWS, ! number of rows in DEST_FIELD CPYFLD1A.75
& MIN_ROW_LENGTH, ! smallest row length in ORIG_FIELD CPYFLD1A.76
& ! or DEST_FIELD CPYFLD1A.77
& MIN_N_ROWS, ! smallest number of rows in ORIG_FIELD CPYFLD1A.78
& ! or DEST_FIELD CPYFLD1A.79
& ORIG_Off_X, ! X offset in ORIG_FIELD for copy loop CPYFLD1A.80
& ORIG_Off_Y, ! Y offset in ORIG_FIELD for copy loop CPYFLD1A.81
& DEST_Off_X, ! X offset in DEST_FIELD for copy loop CPYFLD1A.82
& DEST_Off_Y, ! Y offset in DEST_FIELD for copy loop CPYFLD1A.83
& ORIG_INDEX, ! point in horizontal ORIG_FIELD CPYFLD1A.84
& DEST_INDEX ! point in horizontal DEST_FIELD CPYFLD1A.85
CPYFLD1A.86
INTEGER I,J,K ! loop counters (column,row,level) CPYFLD1A.87
CPYFLD1A.88
! ------------------------------------------------------------------ CPYFLD1A.89
CPYFLD1A.90
! Calculate the shape of DEST_FIELD CPYFLD1A.91
DEST_ROW_LENGTH = ORIG_ROW_LENGTH - ORIG_Offx*2 + DEST_Offx*2 CPYFLD1A.92
DEST_N_ROWS = ORIG_N_ROWS - ORIG_Offy*2 + DEST_Offy*2 CPYFLD1A.93
CPYFLD1A.94
! Set DEST_FIELD to some "safe" value for all locations that aren't CPYFLD1A.95
! set in the copy CPYFLD1A.96
IF(.NOT.L_SWAP)THEN AAD2F404.304
DO K=1,LEVELS CPYFLD1A.97
DO I=1,DEST_FIELD_SIZE CPYFLD1A.98
DEST_FIELD(I,K)=0.0 CPYFLD1A.99
ENDDO CPYFLD1A.100
ENDDO CPYFLD1A.101
ENDIF AAD2F404.305
CPYFLD1A.102
! Calculate the smallest size in each horizontal dimension CPYFLD1A.103
MIN_ROW_LENGTH = MIN(ORIG_ROW_LENGTH,DEST_ROW_LENGTH) CPYFLD1A.104
MIN_N_ROWS = MIN(ORIG_N_ROWS,DEST_N_ROWS) CPYFLD1A.105
CPYFLD1A.106
! Calculate the offsets for the copy loop CPYFLD1A.107
ORIG_Off_X=(ORIG_ROW_LENGTH-MIN_ROW_LENGTH)/2 CPYFLD1A.108
ORIG_Off_Y=(ORIG_N_ROWS-MIN_N_ROWS)/2 CPYFLD1A.109
DEST_Off_X=(DEST_ROW_LENGTH-MIN_ROW_LENGTH)/2 CPYFLD1A.110
DEST_Off_Y=(DEST_N_ROWS-MIN_N_ROWS)/2 CPYFLD1A.111
CPYFLD1A.112
! Copy from ORIG_FIELD to DEST_FIELD CPYFLD1A.113
DO K=1,LEVELS CPYFLD1A.114
DO J=1,MIN_N_ROWS CPYFLD1A.115
DO I=1,MIN_ROW_LENGTH CPYFLD1A.116
DEST_INDEX=I+DEST_Off_X+(J+DEST_Off_Y-1)*DEST_ROW_LENGTH CPYFLD1A.117
ORIG_INDEX=I+ORIG_Off_X+(J+ORIG_Off_Y-1)*ORIG_ROW_LENGTH CPYFLD1A.118
DEST_FIELD(DEST_INDEX,K) = ORIG_FIELD(ORIG_INDEX,K) CPYFLD1A.119
ENDDO CPYFLD1A.120
ENDDO CPYFLD1A.121
ENDDO CPYFLD1A.122
CPYFLD1A.123
IF (L_SWAP) THEN CPYFLD1A.124
! Do a swap to update halos CPYFLD1A.125
CALL SWAPBOUNDS
(DEST_FIELD,DEST_ROW_LENGTH,DEST_N_ROWS, CPYFLD1A.126
& DEST_Offx,DEST_Offy,LEVELS) CPYFLD1A.127
ENDIF CPYFLD1A.128
CPYFLD1A.129
RETURN CPYFLD1A.130
END CPYFLD1A.131
*ENDIF CPYFLD1A.132
*ENDIF GPB3F403.271