SUBROUTINE COPYDIAG_3D(DIAGOUT,DIAGIN,FIRST_POINT,LAST_POINT, 46,3COPD3D1A.30
& FIELD,ROW_LENGTH, COPD3D1A.31
& LEVELS,STLIST,LEN_STLIST,STASH_LEVELS, COPD3D1A.32
& LEN_STASHLEVELS, GPB1F403.650
& IM,IS,IE, GPB1F403.651
*CALL ARGPPX 
GPB1F403.652
& ICODE,CMESSAGE) GPB1F403.653
COPD3D1A.34
IMPLICIT NONE COPD3D1A.35
COPD3D1A.36
INTEGER COPD3D1A.37
& FIRST_POINT, ! First and last points for which data COPD3D1A.38
& LAST_POINT, ! is pressent on input COPD3D1A.39
& FIELD, ! Length of full logical field COPD3D1A.40
& ROW_LENGTH, ! Number of points in a row COPD3D1A.41
& LEVELS, ! Number of levels in input data COPD3D1A.42
& LEN_STLIST, ! COPD3D1A.43
& STLIST(LEN_STLIST), ! STASH list COPD3D1A.44
& LEN_STASHLEVELS, ! COPD3D1A.45
& STASH_LEVELS(LEN_STASHLEVELS,*), ! STASH levels list. COPD3D1A.46
& IM,IS,IE, ! Model, section, item GPB1F403.654
& ICODE ! Return code =0 Normal exit COPD3D1A.47
C >1 Error message COPD3D1A.48
COPD3D1A.49
! ARGPPX arguments: GPB1F403.655
*CALL CSUBMODL GPB1F403.656
*CALL CPPXREF GPB1F403.657
*CALL PPXLOOK GPB1F403.658
GPB1F403.659
CHARACTER*80 CMESSAGE TS150793.43
COPD3D1A.51
REAL COPD3D1A.52
& DIAGIN(FIELD,LEVELS), ! Output data COPD3D1A.53
& DIAGOUT(FIELD,*) ! Input data COPD3D1A.54
COPD3D1A.55
*IF DEF,MPP GPB1F403.660
! MPP common block and parameters GPB1F403.661
*CALL PARVARS GPB1F403.662
*ENDIF GPB1F403.663
GPB1F403.664
C* COPD3D1A.56
C Local variables COPD3D1A.57
COPD3D1A.58
INTEGER COPD3D1A.59
& I, ! COPD3D1A.60
& K, ! COPD3D1A.61
& KOUT, ! COPD3D1A.62
& NP_START , SP_START ! start points of North/South pole rows GPB1F403.665
&, ECOL_START , WCOL_START ! start points of East/West boundaries GPB1F403.666
&, START_POINT,END_POINT ! MPP modified versions of FIRST/LAST GPB1F403.667
*IF DEF,MPP GPB1F403.668
&, GR ! grid type of grid GPB1F403.669
&, FLD_TYPE ! is it a p field or a u field? GPB1F403.670
&, info ! GCOM return code GPB1F403.671
GPB1F403.672
! Functions called: GPB1F403.673
INTEGER GPB1F403.674
& EXPPXI,GET_FLD_TYPE GPB1F403.675
GPB1F403.676
*ENDIF GPB1F403.677
GPB1F403.678
REAL GPB1F403.679
& COPY_VALUE_START(LEVELS) ! value to copy into start of array GPB1F403.680
&, COPY_VALUE_END(LEVELS) ! value to copy into end of array GPB1F403.681
GPB1F403.682
COPD3D1A.64
LOGICAL COPD3D1A.65
& LIST(LEVELS) ! COPD3D1A.66
COPD3D1A.67
*IF DEF,MPP GPB1F403.683
! Find out the gridtype of the field GPB1F403.684
GR = EXPPXI(IM,IS,IE,ppx_grid_type, GPB1F403.685
*CALL ARGPPX GPB1F403.686
& ICODE,CMESSAGE) GPB1F403.687
GPB1F403.688
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.689
GPB1F403.690
! and use this to find the field type (p field or u field) GPB1F403.691
GPB1F403.692
FLD_TYPE=GET_FLD_TYPE(GR) GPB1F403.693
GPB1F403.694
*ENDIF GPB1F403.695
GPB1F403.696
! Set START_POINT and END_POINT GPB1F403.697
*IF -DEF,MPP GPB1F403.698
START_POINT=FIRST_POINT GPB1F403.699
END_POINT=LAST_POINT GPB1F403.700
*ELSE GPB1F403.701
! Place START and END to be in real data - not in the halos GPB1F403.702
START_POINT=FIRST_POINT+Offx GPB1F403.703
END_POINT=LAST_POINT-Offx GPB1F403.704
*ENDIF GPB1F403.705
GPB1F403.706
! Find the values to copy into the start and end of the arrays GPB1F403.707
GPB1F403.708
DO K=1,LEVELS GPB1F403.709
COPY_VALUE_START(K)=DIAGIN(START_POINT,K) GPB1F403.710
COPY_VALUE_END(K)=DIAGIN(END_POINT,K) GPB1F403.711
ENDDO GPB1F403.712
GPB1F403.713
*IF DEF,MPP GPB1F403.714
! If this is the Northern processor row - we must make sure we GPB1F403.715
! get a consistent value over the polar row - so we take GPB1F403.716
! the value from PE 0 and use that on all processors GPB1F403.717
IF (attop) THEN GPB1F403.718
CALL GCG_RBCAST(700,LEVELS,first_comp_pe,gc_proc_row_group, GPB1F403.719
& info,COPY_VALUE_START) GPB1F403.720
ENDIF GPB1F403.721
GPB1F403.722
! If this is the Southern processor row - we must make sure we GPB1F403.723
! get a consistent value over the polar row - so we take GPB1F403.724
! the value from PE 0 and use that on all processors GPB1F403.725
IF (atbase) THEN GPB1F403.726
CALL GCG_RBCAST(701,LEVELS,last_comp_pe,gc_proc_row_group, GPB1F403.727
& info,COPY_VALUE_END) GPB1F403.728
ENDIF GPB1F403.729
*ENDIF GPB1F403.730
CALL SET_LEVELS_LIST(LEVELS,LEN_STLIST,STLIST,LIST,STASH_LEVELS, COPD3D1A.68
& LEN_STASHLEVELS,ICODE,CMESSAGE) COPD3D1A.69
IF(ICODE.GT.0) GOTO 9999 GPB1F403.731
COPD3D1A.71
CL Move data from DIAGIN to DIAGOUT at levels requested COPD3D1A.72
COPD3D1A.73
KOUT=0 COPD3D1A.74
DO K=1,LEVELS COPD3D1A.75
IF(LIST(K)) THEN COPD3D1A.76
KOUT=KOUT+1 COPD3D1A.77
COPD3D1A.78
DO I=START_POINT,END_POINT GPB1F403.732
DIAGOUT(I,KOUT)=DIAGIN(I,K) COPD3D1A.80
END DO COPD3D1A.81
COPD3D1A.82
DO I=1,START_POINT-1 GPB1F403.733
DIAGOUT(I,KOUT)=COPY_VALUE_START(K) GPB1F403.734
END DO COPD3D1A.85
COPD3D1A.86
DO I=END_POINT+1,FIELD GPB1F403.735
DIAGOUT(I,KOUT)=COPY_VALUE_END(K) GPB1F403.736
END DO COPD3D1A.89
COPD3D1A.90
*IF -DEF,GLOBAL COPD3D1A.91
COPD3D1A.92
CL Copy diagnostic information to N and S boundaries COPD3D1A.93
COPD3D1A.94
*IF DEF,MPP GPB1F403.737
IF (attop) THEN GPB1F403.738
NP_START=Offy*ROW_LENGTH+1 GPB1F403.739
*ELSE GPB1F403.740
NP_START=1 GPB1F403.741
*ENDIF GPB1F403.742
DO I=NP_START,NP_START+ROW_LENGTH-1 GPB1F403.743
DIAGOUT(I,KOUT)=DIAGOUT(I+ROW_LENGTH,KOUT) GPB1F403.744
ENDDO GPB1F403.745
*IF DEF,MPP GPB1F403.746
ENDIF GPB1F403.747
GPB1F403.748
IF (atbase) THEN GPB1F403.749
IF (FLD_TYPE .EQ. fld_type_p) THEN GPB1F403.750
SP_START=FIELD-(Offy+1)*ROW_LENGTH+1 GPB1F403.751
ELSE GPB1F403.752
SP_START=FIELD-(Offy+2)*ROW_LENGTH+1 GPB1F403.753
ENDIF GPB1F403.754
*ELSE GPB1F403.755
GPB1F403.756
SP_START=FIELD-ROW_LENGTH+1 GPB1F403.757
*ENDIF GPB1F403.758
DO I=SP_START,SP_START+ROW_LENGTH-1 GPB1F403.759
DIAGOUT(I,KOUT)=DIAGOUT(I-ROW_LENGTH,KOUT) GPB1F403.760
ENDDO GPB1F403.761
*IF DEF,MPP GPB1F403.762
ENDIF GPB1F403.763
*ENDIF GPB1F403.764
COPD3D1A.100
CL Copy diagnostic information to E and W boundaries COPD3D1A.101
COPD3D1A.102
*IF DEF,MPP GPB1F403.765
IF (atleft) THEN GPB1F403.766
GPB1F403.767
WCOL_START=Offy*ROW_LENGTH+1+Offx GPB1F403.768
*ELSE GPB1F403.769
WCOL_START=1 GPB1F403.770
*ENDIF GPB1F403.771
DO I=WCOL_START,FIELD,ROW_LENGTH GPB1F403.772
DIAGOUT(I,KOUT)=DIAGOUT(I+1,KOUT) GPB1F403.773
ENDDO GPB1F403.774
*IF DEF,MPP GPB1F403.775
ENDIF GPB1F403.776
GPB1F403.777
IF (atright) THEN GPB1F403.778
GPB1F403.779
ECOL_START=(Offy+1)*ROW_LENGTH-Offx GPB1F403.780
*ELSE GPB1F403.781
GPB1F403.782
ECOL_START=ROW_LENGTH GPB1F403.783
*ENDIF GPB1F403.784
DO I=ECOL_START,FIELD,ROW_LENGTH GPB1F403.785
DIAGOUT(I,KOUT)=DIAGOUT(I-1,KOUT) GPB1F403.786
ENDDO GPB1F403.787
*IF DEF,MPP GPB1F403.788
ENDIF GPB1F403.789
*ENDIF GPB1F403.790
COPD3D1A.108
*ENDIF COPD3D1A.109
COPD3D1A.110
END IF COPD3D1A.111
END DO COPD3D1A.112
COPD3D1A.113
9999 CONTINUE GPB1F403.791
RETURN COPD3D1A.114
END COPD3D1A.115
*ENDIF COPD3D1A.116
*ENDIF AJC0F405.263