*IF DEF,CONTROL SETEXNE1.2
C ******************************COPYRIGHT****************************** GTS2F400.8515
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.8516
C GTS2F400.8517
C Use, duplication or disclosure of this code is subject to the GTS2F400.8518
C restrictions as set forth in the contract. GTS2F400.8519
C GTS2F400.8520
C Meteorological Office GTS2F400.8521
C London Road GTS2F400.8522
C BRACKNELL GTS2F400.8523
C Berkshire UK GTS2F400.8524
C RG12 2SZ GTS2F400.8525
C GTS2F400.8526
C If no contract has been raised with this copy of the code, the use, GTS2F400.8527
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.8528
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.8529
C Modelling at the above address. GTS2F400.8530
C ******************************COPYRIGHT****************************** GTS2F400.8531
C GTS2F400.8532
*IF DEF,ATMOS,AND,DEF,REPROD SETEXNE1.3
CLL Routine: SETEXNER ------------------------------------------------- SETEXNE1.4
CLL SETEXNE1.5
CLL Purpose: Calculates P_EXNER field from PSTAR and stores in D1. SETEXNE1.6
CLL SETEXNE1.7
CLL Tested under compiler: cft77 SETEXNE1.8
CLL Tested under OS version: UNICOS 5.1 SETEXNE1.9
CLL SETEXNE1.10
CLL Author: T.C.Johns SETEXNE1.11
CLL SETEXNE1.12
CLL Model Modification history from model version 3.0: SETEXNE1.13
CLL version date SETEXNE1.14
CLL 3.2 27/03/93 Dynamic allocation of main data arrays. R. Rawlins @DYALLOC.3223
!LL 4.5 27/04/98 Add Fujitsu vectorization directive. GRB0F405.49
!LL RBarnes@ecmwf.int GRB0F405.50
CLL SETEXNE1.15
CLL Programming standard: UM Doc Paper 3, version 2 (7/9/90) SETEXNE1.16
CLL SETEXNE1.17
CLL Logical components covered: P199 SETEXNE1.18
CLL SETEXNE1.19
CLL Project task: P0 SETEXNE1.20
CLL SETEXNE1.21
CLL External documentation: SETEXNE1.22
CLL Unified Model Doc Paper P0 - Atmospheric Model Structure SETEXNE1.23
CLL SETEXNE1.24
CLL ------------------------------------------------------------------- SETEXNE1.25
C*L Interface and arguments: ------------------------------------------ SETEXNE1.26
C SETEXNE1.27
SUBROUTINE SETEXNER( 2@DYALLOC.3224
*CALL ARGSIZE 
@DYALLOC.3225
*CALL ARGD1 @DYALLOC.3226
*CALL ARGPTRA @DYALLOC.3227
*CALL ARGCONA @DYALLOC.3228
& ICODE,CMESSAGE) @DYALLOC.3229
C SETEXNE1.29
IMPLICIT NONE SETEXNE1.30
C SETEXNE1.31
C @DYALLOC.3230
INTEGER ICODE ! OUT: Error return code @DYALLOC.3231
CHARACTER*256 CMESSAGE ! OUT: Error return message @DYALLOC.3232
C @DYALLOC.3233
*CALL CMAXSIZE @DYALLOC.3234
*CALL TYPSIZE @DYALLOC.3235
*CALL TYPD1 @DYALLOC.3236
*CALL TYPPTRA @DYALLOC.3237
*CALL TYPCONA @DYALLOC.3238
C*---------------------------------------------------------------------- SETEXNE1.32
C Common blocks SETEXNE1.33
C SETEXNE1.34
*CALL CPHYSCON SETEXNE1.38
C SETEXNE1.39
C Local variables SETEXNE1.40
C SETEXNE1.41
INTEGER SETEXNE1.42
& LEVEL,I SETEXNE1.43
SETEXNE1.44
C Calculate P_EXNER SETEXNE1.45
SETEXNE1.46
DO LEVEL=1,P_LEVELS+1 SETEXNE1.47
! Fujitsu vectorization directive GRB0F405.51
!OCL NOVREC GRB0F405.52
DO I=1,P_FIELD SETEXNE1.48
D1(JP_EXNER(LEVEL)+I-1)=((AKH(LEVEL)+BKH(LEVEL)* SETEXNE1.49
& D1(JPSTAR+I-1))/PREF)**KAPPA SETEXNE1.50
ENDDO SETEXNE1.51
ENDDO SETEXNE1.52
SETEXNE1.53
RETURN SETEXNE1.54
END SETEXNE1.55
SETEXNE1.56
*ENDIF SETEXNE1.57
*ENDIF SETEXNE1.58