*IF DEF,C90_1A,OR,DEF,C90_2A,OR,DEF,C90_2B AAD2F404.299
C ******************************COPYRIGHT****************************** GTS2F400.829
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.830
C GTS2F400.831
C Use, duplication or disclosure of this code is subject to the GTS2F400.832
C restrictions as set forth in the contract. GTS2F400.833
C GTS2F400.834
C Meteorological Office GTS2F400.835
C London Road GTS2F400.836
C BRACKNELL GTS2F400.837
C Berkshire UK GTS2F400.838
C RG12 2SZ GTS2F400.839
C GTS2F400.840
C If no contract has been raised with this copy of the code, the use, GTS2F400.841
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.842
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.843
C Modelling at the above address. GTS2F400.844
C ******************************COPYRIGHT****************************** GTS2F400.845
C GTS2F400.846
!+ Change 1st dimension of 2 dimensional array. CHGDIM1A.3
! CHGDIM1A.4
! Subroutine Interface: CHGDIM1A.5
SUBROUTINE CHANGE_DIMENS(X,INSIZE,OUTSIZE,LEVELS,ICODE) 1CHGDIM1A.6
CHGDIM1A.7
IMPLICIT NONE CHGDIM1A.8
! CHGDIM1A.9
! Description and Method: CHGDIM1A.10
! Convert array a(insize,levels) with elements a((i=1,outsize),levels) CHGDIM1A.11
! defined to an array of contiguous elements such that it is CHGDIM1A.12
! equivalent to an array of dimension (outsize,levels). CHGDIM1A.13
! Note that outsize must be le insize. CHGDIM1A.14
! CHGDIM1A.15
! Current Code Owner: Rick Rawlins (FR) CHGDIM1A.16
! CHGDIM1A.17
! History: CHGDIM1A.18
! Version Date Comment CHGDIM1A.19
! ------- ---- ------- CHGDIM1A.20
! 3.4 15/07/94 Original code. RR; implemented by RTHBarnes. CHGDIM1A.21
! 4.5 27/04/98 Add Fujitsu vectorization directive. GRB0F405.41
! RBarnes@ecmwf.int GRB0F405.42
! CHGDIM1A.22
! Code Description: CHGDIM1A.23
! Language: FORTRAN 77 + common extensions. CHGDIM1A.24
! This code is written to UMDP3 v6 programming standards. CHGDIM1A.25
! CHGDIM1A.26
! System component covered: <appropriate code> CHGDIM1A.27
! System Task: <appropriate code> CHGDIM1A.28
! CHGDIM1A.29
! Declarations: CHGDIM1A.30
! CHGDIM1A.31
! Global variables (*CALLed COMDECKs etc...): CHGDIM1A.32
CHGDIM1A.33
! Subroutine arguments CHGDIM1A.34
! Scalar arguments with intent(in): CHGDIM1A.35
INTEGER CHGDIM1A.36
& INSIZE ! IN Input first dimension CHGDIM1A.37
& ,OUTSIZE ! IN Output first dimension CHGDIM1A.38
& ,LEVELS ! IN Input second dimension CHGDIM1A.39
! Array arguments with intent(in): CHGDIM1A.40
! Scalar arguments with intent(InOut): CHGDIM1A.41
INTEGER ICODE ! INOUT Return code CHGDIM1A.42
! Array arguments with intent(InOut): CHGDIM1A.43
REAL X(INSIZE*LEVELS) ! INOUT Array for redimensioning CHGDIM1A.44
! Scalar arguments with intent(out): CHGDIM1A.45
! Array arguments with intent(out): CHGDIM1A.46
CHGDIM1A.47
! Local parameters: CHGDIM1A.48
CHGDIM1A.49
! Local scalars: CHGDIM1A.50
INTEGER CHGDIM1A.51
& I,LEVEL,I1,I2 ! Local loops and counters CHGDIM1A.52
! Local dynamic arrays: CHGDIM1A.53
CHGDIM1A.54
! Function & Subroutine calls: CHGDIM1A.55
! External - NONE CHGDIM1A.56
CHGDIM1A.57
IF (OUTSIZE.GT.INSIZE) THEN CHGDIM1A.58
write(6,*) 'CHANGE_DIMENS: ERROR, OUTSIZE GT INSIZE' CHGDIM1A.59
ICODE = 1 CHGDIM1A.60
GO TO 9999 CHGDIM1A.61
END IF CHGDIM1A.62
DO LEVEL = 1,LEVELS CHGDIM1A.63
I1 = (LEVEL-1)*INSIZE CHGDIM1A.64
I2 = (LEVEL-1)*OUTSIZE CHGDIM1A.65
! Fujitsu vectorization directive GRB0F405.43
!OCL NOVREC GRB0F405.44
DO I = 1,OUTSIZE CHGDIM1A.66
X(I+I2) = X(I+I1) CHGDIM1A.67
END DO CHGDIM1A.68
END DO CHGDIM1A.69
9999 CONTINUE CHGDIM1A.70
RETURN CHGDIM1A.71
END CHGDIM1A.72
*ENDIF CHGDIM1A.73