SUBROUTINE COPYDIAG(DIAGOUT,DIAGIN,FIRST_POINT,LAST_POINT,FIELD, 94,2COPDIA1A.30
& ROW_LENGTH, GPB1F403.794
& IM,IS,IE, GPB1F403.795
*CALL ARGPPX 
GPB1F403.796
& ICODE,CMESSAGE) GPB1F403.797
COPDIA1A.32
IMPLICIT NONE COPDIA1A.33
COPDIA1A.34
INTEGER COPDIA1A.35
& FIRST_POINT, ! First and last points for which data COPDIA1A.36
& LAST_POINT, ! is pressent on input COPDIA1A.37
& FIELD, ! Length of full logical field COPDIA1A.38
& ROW_LENGTH ! Number of points in a row COPDIA1A.39
&, IM,IS,IE ! Model, section, item GPB1F403.798
&, ICODE ! Return code =0 Normal exit >1 Error GPB1F403.799
GPB1F403.800
CHARACTER*80 CMESSAGE GPB1F403.801
GPB1F403.802
! ARGPPX arguments: GPB1F403.803
*CALL CSUBMODL GPB1F403.804
*CALL CPPXREF GPB1F403.805
*CALL PPXLOOK GPB1F403.806
GPB1F403.807
COPDIA1A.40
REAL COPDIA1A.41
& DIAGIN(FIELD), ! Output data COPDIA1A.42
& DIAGOUT(FIELD) ! Input data COPDIA1A.43
COPDIA1A.44
GPB1F403.808
*IF DEF,MPP GPB1F403.809
! MPP common block and parameters GPB1F403.810
*CALL PARVARS GPB1F403.811
*ENDIF GPB1F403.812
C* COPDIA1A.45
C Local variables COPDIA1A.46
COPDIA1A.47
INTEGER GPB1F403.813
& I ! loop bound GPB1F403.814
&, NP_START , SP_START ! start points of North/South pole rows GPB1F403.815
&, ECOL_START , WCOL_START ! start points of East/West boundaries GPB1F403.816
&, START_POINT,END_POINT ! MPP modified versions of FIRST/LAST GPB1F403.817
*IF DEF,MPP GPB1F403.818
&, GR ! grid type of grid GPB1F403.819
&, FLD_TYPE ! is it a p field or a u field? GPB1F403.820
&, info ! GCOM return code GPB1F403.821
GPB1F403.822
! Functions called: GPB1F403.823
INTEGER GPB1F403.824
& EXPPXI,GET_FLD_TYPE GPB1F403.825
GPB1F403.826
*ENDIF GPB1F403.827
GPB1F403.828
REAL GPB1F403.829
& COPY_VALUE ! value to copy into start/end of array GPB1F403.830
GPB1F403.831
*IF DEF,MPP GPB1F403.832
! Find out the gridtype of the field GPB1F403.833
GR = EXPPXI(IM,IS,IE,ppx_grid_type, GPB1F403.834
*CALL ARGPPX GPB1F403.835
& ICODE,CMESSAGE) GPB1F403.836
GPB1F403.837
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.838
GPB1F403.839
! and use this to find the field type (p field or u field) GPB1F403.840
GPB1F403.841
FLD_TYPE=GET_FLD_TYPE(GR) GPB1F403.842
GPB1F403.843
*ENDIF GPB1F403.844
GPB1F403.845
! Set START_POINT and END_POINT GPB1F403.846
*IF -DEF,MPP GPB1F403.847
START_POINT=FIRST_POINT GPB1F403.848
END_POINT=LAST_POINT GPB1F403.849
*ELSE GPB1F403.850
! Place START and END to be in real data - not in the halos GPB1F403.851
START_POINT=FIRST_POINT+Offx GPB1F403.852
END_POINT=LAST_POINT-Offx GPB1F403.853
*ENDIF GPB1F403.854
GPB1F403.855
COPDIA1A.51
DO I=START_POINT,END_POINT GPB1F403.856
DIAGOUT(I)=DIAGIN(I) COPDIA1A.53
END DO COPDIA1A.54
COPDIA1A.55
! Set the START of the array to a constant value GPB1F403.857
COPY_VALUE=DIAGIN(START_POINT) GPB1F403.858
*IF DEF,MPP GPB1F403.859
! If this is the Northern processor row - we must make sure we GPB1F403.860
! get a consistent value over the polar row - so we take GPB1F403.861
! the value from PE 0 and use that on all processors GPB1F403.862
IF (attop) THEN GPB1F403.863
CALL GCG_RBCAST(700,1,first_comp_pe,gc_proc_row_group, GPB1F403.864
& info,COPY_VALUE) GPB1F403.865
ENDIF GPB1F403.866
*ENDIF GPB1F403.867
GPB1F403.868
DO I=1,START_POINT-1 GPB1F403.869
DIAGOUT(I)=COPY_VALUE GPB1F403.870
ENDDO GPB1F403.871
GPB1F403.872
COPY_VALUE=DIAGIN(END_POINT) GPB1F403.873
*IF DEF,MPP GPB1F403.874
! If this is the Southern processor row - we must make sure we GPB1F403.875
! get a consistent value over the polar row - so we take GPB1F403.876
! the value from PE 0 and use that on all processors GPB1F403.877
IF (atbase) THEN GPB1F403.878
CALL GCG_RBCAST(701,1,last_comp_pe,gc_proc_row_group, GPB1F403.879
& info,COPY_VALUE) GPB1F403.880
ENDIF GPB1F403.881
*ENDIF GPB1F403.882
GPB1F403.883
DO I=END_POINT+1,FIELD GPB1F403.884
DIAGOUT(I)=COPY_VALUE GPB1F403.885
ENDDO GPB1F403.886
COPDIA1A.63
*IF -DEF,GLOBAL COPDIA1A.64
COPDIA1A.65
CL Copy diagnostic information to N and S boundaries COPDIA1A.66
COPDIA1A.67
*IF DEF,MPP GPB1F403.887
IF (attop) THEN GPB1F403.888
NP_START=Offy*ROW_LENGTH+1 GPB1F403.889
*ELSE GPB1F403.890
NP_START=1 GPB1F403.891
*ENDIF GPB1F403.892
DO I=NP_START,NP_START+ROW_LENGTH-1 GPB1F403.893
DIAGOUT(I)=DIAGOUT(I+ROW_LENGTH) GPB1F403.894
ENDDO GPB1F403.895
*IF DEF,MPP GPB1F403.896
ENDIF GPB1F403.897
GPB1F403.898
IF (atbase) THEN GPB1F403.899
IF (FLD_TYPE .EQ. fld_type_p) THEN GPB1F403.900
SP_START=FIELD-(Offy+1)*ROW_LENGTH+1 GPB1F403.901
ELSE GPB1F403.902
SP_START=FIELD-(Offy+2)*ROW_LENGTH+1 GPB1F403.903
ENDIF GPB1F403.904
*ELSE GPB1F403.905
GPB1F403.906
SP_START=FIELD-ROW_LENGTH+1 GPB1F403.907
*ENDIF GPB1F403.908
DO I=SP_START,SP_START+ROW_LENGTH-1 GPB1F403.909
DIAGOUT(I)=DIAGOUT(I-ROW_LENGTH) GPB1F403.910
ENDDO GPB1F403.911
*IF DEF,MPP GPB1F403.912
ENDIF GPB1F403.913
*ENDIF GPB1F403.914
COPDIA1A.72
CL Copy diagnostic information to E and W boundaries COPDIA1A.73
COPDIA1A.74
*IF DEF,MPP GPB1F403.915
IF (atleft) THEN GPB1F403.916
GPB1F403.917
WCOL_START=Offy*ROW_LENGTH+1+Offx GPB1F403.918
*ELSE GPB1F403.919
WCOL_START=1 GPB1F403.920
*ENDIF GPB1F403.921
DO I=WCOL_START,FIELD,ROW_LENGTH GPB1F403.922
DIAGOUT(I)=DIAGOUT(I+1) GPB1F403.923
ENDDO GPB1F403.924
*IF DEF,MPP GPB1F403.925
ENDIF GPB1F403.926
GPB1F403.927
IF (atright) THEN GPB1F403.928
GPB1F403.929
ECOL_START=(Offy+1)*ROW_LENGTH-Offx GPB1F403.930
*ELSE GPB1F403.931
GPB1F403.932
ECOL_START=ROW_LENGTH GPB1F403.933
*ENDIF GPB1F403.934
DO I=ECOL_START,FIELD,ROW_LENGTH GPB1F403.935
DIAGOUT(I)=DIAGOUT(I-1) GPB1F403.936
ENDDO GPB1F403.937
*IF DEF,MPP GPB1F403.938
ENDIF GPB1F403.939
*ENDIF GPB1F403.940
COPDIA1A.80
*ENDIF COPDIA1A.81
COPDIA1A.82
9999 CONTINUE GPB1F403.941
RETURN COPDIA1A.83
END COPDIA1A.84
*ENDIF COPDIA1A.85