SUBROUTINE BOUNDVAL( 1,23@DYALLOC.668
*CALL ARGSIZE 
@DYALLOC.669
*CALL ARGD1 @DYALLOC.670
*CALL ARGDUMA @DYALLOC.671
*CALL ARGPTRA @DYALLOC.672
*CALL ARGBND @DYALLOC.673
& ICODE,CMESSAGE) @DYALLOC.674
BOUNDVA1.33
IMPLICIT NONE BOUNDVA1.34
BOUNDVA1.35
*CALL CMAXSIZE @DYALLOC.675
*CALL TYPSIZE @DYALLOC.676
*CALL TYPD1 @DYALLOC.677
*CALL TYPDUMA @DYALLOC.678
*CALL TYPPTRA @DYALLOC.679
*CALL TYPBND @DYALLOC.680
*IF DEF,MPP APB4F401.4
*CALL PARVARS APB4F401.5
*ENDIF APB4F401.6
@DYALLOC.681
INTEGER @DYALLOC.682
& ICODE ! Return code = 0 Normal Exit @DYALLOC.683
C ! " " > 0 Error Exit @DYALLOC.684
@DYALLOC.685
CHARACTER*(80) CMESSAGE ! Error message if ICODE > 0 ANF0F304.6
C @DYALLOC.687
*CALL CNTLATM ARB1F404.22
*CALL CLOOKADD BOUNDVA1.39
BOUNDVA1.40
EXTERNAL BOUNDVA1.41
*IF DEF,MPP ARB1F404.23
& MPP_MERGEFLD ARB1F404.24
*ELSE ARB1F404.25
& MERGEFLD BOUNDVA1.42
*ENDIF ARB1F404.26
BOUNDVA1.43
C* BOUNDVA1.44
C Local variables BOUNDVA1.45
BOUNDVA1.46
REAL BOUNDVA1.47
& SCALAR BOUNDVA1.48
& ,TEMP(LENRIMA) ARB1F404.27
BOUNDVA1.49
INTEGER BOUNDVA1.50
& I, BOUNDVA1.51
& LEVEL, BOUNDVA1.52
& IADDR, BOUNDVA1.53
& VAR BOUNDVA1.54
BOUNDVA1.55
CL Internal structure BOUNDVA1.56
BOUNDVA1.57
CL 1.0 UPDATE BOUNDARY VALUES BOUNDVA1.58
BOUNDVA1.59
CL 1.1 Check if using fixed boundaries BOUNDVA1.60
IF ( BOUND_FIELDCODE(1).LE.0) RETURN BOUNDVA1.61
BOUNDVA1.62
SCALAR=1.0/REAL(RIM_STEPSA) BOUNDVA1.63
DO 100 I=1,LENRIMDATA_A BOUNDVA1.64
D1(JRIM+I-1)=D1(JRIM+I-1)+D1(JRIM_TENDENCY+I-1)*SCALAR BOUNDVA1.65
100 CONTINUE BOUNDVA1.66
BOUNDVA1.67
CL 2.0 Loop over fields to be updated BOUNDVA1.68
BOUNDVA1.69
BOUNDVA1.70
C PSTAR BOUNDVA1.71
BOUNDVA1.72
*IF -DEF,MPP APB4F401.7
CALL MERGEFLD(ROW_LENGTH,ROW_LENGTH,P_ROWS,RIMWIDTHA, BOUNDVA1.73
& RIMWEIGHTSA,D1(JRIM),D1(JPSTAR)) BOUNDVA1.74
*ELSE APB4F401.8
CALL MPP_MERGEFLD(ROW_LENGTH,P_ROWS, APB4F401.9
& LENRIMA,RIMWIDTHA,RIMWEIGHTSA, APB4F401.10
& fld_type_p,D1(JRIM),D1(JPSTAR)) APB4F401.11
*ENDIF APB4F401.12
BOUNDVA1.75
IADDR=JRIM+LENRIMA BOUNDVA1.76
BOUNDVA1.77
C U BOUNDVA1.78
BOUNDVA1.79
DO 20 LEVEL=1,P_LEVELS BOUNDVA1.80
BOUNDVA1.81
*IF -DEF,MPP APB4F401.13
CALL MERGEFLD(ROW_LENGTH-1,ROW_LENGTH,U_ROWS,RIMWIDTHA, BOUNDVA1.82
& RIMWEIGHTSA,D1(IADDR),D1(JU(LEVEL))) BOUNDVA1.83
BOUNDVA1.84
DO 205 I=ROW_LENGTH,U_FIELD,ROW_LENGTH BOUNDVA1.85
D1(JU(LEVEL)+I-1) = D1(JU(LEVEL)+I-2) BOUNDVA1.86
205 CONTINUE BOUNDVA1.87
BOUNDVA1.88
IADDR=IADDR+LENRIMA-4*RIMWIDTHA BOUNDVA1.89
*ELSE APB4F401.14
CALL MPP_MERGEFLD(ROW_LENGTH,P_ROWS, APB4F401.15
& LENRIMA_U,RIMWIDTHA,RIMWEIGHTSA, APB4F401.16
& fld_type_u,D1(IADDR),D1(JU(LEVEL))) APB4F401.17
APB4F401.18
IF (atright) THEN APB4F401.19
DO I=ROW_LENGTH,U_FIELD,ROW_LENGTH APB4F401.20
D1(JU(LEVEL)+I-1-Offx) = D1(JU(LEVEL)+I-2-Offx) APB4F401.21
ENDDO APB4F401.22
ENDIF APB4F401.23
APB4F401.24
IADDR=IADDR+LENRIMA_U APB4F401.25
*ENDIF APB4F401.26
BOUNDVA1.90
20 CONTINUE BOUNDVA1.91
BOUNDVA1.92
C V BOUNDVA1.93
BOUNDVA1.94
DO 21 LEVEL=1,P_LEVELS BOUNDVA1.95
*IF -DEF,MPP APB4F401.27
CALL MERGEFLD(ROW_LENGTH-1,ROW_LENGTH,U_ROWS,RIMWIDTHA, BOUNDVA1.96
& RIMWEIGHTSA,D1(IADDR),D1(JV(LEVEL))) BOUNDVA1.97
BOUNDVA1.98
BOUNDVA1.99
DO 215 I=ROW_LENGTH,U_FIELD,ROW_LENGTH BOUNDVA1.100
D1(JV(LEVEL)+I-1) = D1(JV(LEVEL)+I-2) BOUNDVA1.101
215 CONTINUE BOUNDVA1.102
BOUNDVA1.103
IADDR=IADDR+LENRIMA-4*RIMWIDTHA BOUNDVA1.104
*ELSE APB4F401.28
CALL MPP_MERGEFLD(ROW_LENGTH,P_ROWS, APB4F401.29
& LENRIMA_U,RIMWIDTHA,RIMWEIGHTSA, APB4F401.30
& fld_type_u,D1(IADDR),D1(JV(LEVEL))) APB4F401.31
APB4F401.32
IF (atright) THEN APB4F401.33
DO I=ROW_LENGTH,U_FIELD,ROW_LENGTH APB4F401.34
D1(JV(LEVEL)+I-1-Offx) = D1(JV(LEVEL)+I-2-Offx) APB4F401.35
ENDDO APB4F401.36
ENDIF APB4F401.37
APB4F401.38
IADDR=IADDR+LENRIMA_U APB4F401.39
*ENDIF APB4F401.40
BOUNDVA1.105
21 CONTINUE BOUNDVA1.106
BOUNDVA1.107
C THETAL BOUNDVA1.108
BOUNDVA1.109
DO 22 LEVEL=1,P_LEVELS BOUNDVA1.110
BOUNDVA1.111
*IF -DEF,MPP APB4F401.41
CALL MERGEFLD(ROW_LENGTH,ROW_LENGTH,P_ROWS,RIMWIDTHA, BOUNDVA1.112
& RIMWEIGHTSA,D1(IADDR),D1(JTHETA(LEVEL))) BOUNDVA1.113
*ELSE APB4F401.42
CALL MPP_MERGEFLD(ROW_LENGTH,P_ROWS, APB4F401.43
& LENRIMA,RIMWIDTHA,RIMWEIGHTSA, APB4F401.44
& fld_type_p,D1(IADDR),D1(JTHETA(LEVEL))) APB4F401.45
*ENDIF APB4F401.46
do i=jtheta(level),jtheta(level)+p_field-1 PXNEGQ.1
if (d1(i) .lt. 0.0) then PXNEGQ.2
write(6,*)'Theta at level ',level,' point ',i,d1(i) PXNEGQ.3
d1(i)=0.0 PXNEGQ.4
endif PXNEGQ.5
enddo PXNEGQ.6
BOUNDVA1.114
IADDR=IADDR+LENRIMA BOUNDVA1.115
BOUNDVA1.116
22 CONTINUE BOUNDVA1.117
BOUNDVA1.118
C QT BOUNDVA1.119
BOUNDVA1.120
DO 23 LEVEL=1,Q_LEVELS BOUNDVA1.121
BOUNDVA1.122
*IF -DEF,MPP APB4F401.47
CALL MERGEFLD(ROW_LENGTH,ROW_LENGTH,P_ROWS,RIMWIDTHA, BOUNDVA1.123
& RIMWEIGHTSA,D1(IADDR),D1(JQ(LEVEL))) BOUNDVA1.124
*ELSE APB4F401.48
CALL MPP_MERGEFLD(ROW_LENGTH,P_ROWS, APB4F401.49
& LENRIMA,RIMWIDTHA,RIMWEIGHTSA, APB4F401.50
& fld_type_p,D1(IADDR),D1(JQ(LEVEL))) APB4F401.51
*ENDIF APB4F401.52
do i=jq(level),jq(level)+p_field-1 PXNEGQ.7
if (d1(i) .lt. 0.0) then PXNEGQ.8
write(6,*)'Q at level ',level,' point ',i,d1(i) PXNEGQ.9
d1(i)=0.0 PXNEGQ.10
endif PXNEGQ.11
enddo PXNEGQ.12
BOUNDVA1.125
IADDR=IADDR+LENRIMA BOUNDVA1.126
BOUNDVA1.127
BOUNDVA1.128
23 CONTINUE BOUNDVA1.129
BOUNDVA1.130
C TRACERS BOUNDVA1.131
BOUNDVA1.132
IF (TR_VARS.gt.0) THEN ARB1F404.28
DO 26 VAR=1,TR_VARS BOUNDVA1.133
DO 27 LEVEL=1,TR_LEVELS BOUNDVA1.134
BOUNDVA1.135
*IF -DEF,MPP APB4F401.53
CALL MERGEFLD(ROW_LENGTH,ROW_LENGTH,P_ROWS,RIMWIDTHA, BOUNDVA1.136
& RIMWEIGHTSA,D1(IADDR),D1(JTRACER(LEVEL,VAR))) GPB0F405.125
*ELSE APB4F401.54
CALL MPP_MERGEFLD(ROW_LENGTH,P_ROWS, APB4F401.55
& LENRIMA,RIMWIDTHA,RIMWEIGHTSA, APB4F401.56
& fld_type_p,D1(IADDR),D1(JTRACER(LEVEL,VAR))) GPB0F405.126
*ENDIF APB4F401.58
BOUNDVA1.138
IADDR=IADDR+LENRIMA BOUNDVA1.139
BOUNDVA1.140
27 CONTINUE BOUNDVA1.141
26 CONTINUE BOUNDVA1.142
END IF ! TR_VARS ARB1F404.29
BOUNDVA1.143
C QCF ARB1F404.30
ARB1F404.31
IF (L_LSPICE_BDY) THEN ARB1F404.32
DO 24 LEVEL=1,Q_LEVELS ARB1F404.33
ARB1F404.34
*IF -DEF,MPP ARB1F404.35
CALL MERGEFLD(ROW_LENGTH,ROW_LENGTH,P_ROWS,RIMWIDTHA, ARB1F404.36
& RIMWEIGHTSA,D1(IADDR),D1(JQCF(LEVEL))) ARB1F404.37
*ELSE ARB1F404.38
CALL MPP_MERGEFLD(ROW_LENGTH,P_ROWS, ARB1F404.39
& LENRIMA,RIMWIDTHA,RIMWEIGHTSA, ARB1F404.40
& fld_type_p,D1(IADDR),D1(JQCF(LEVEL))) ARB1F404.41
*ENDIF ARB1F404.42
ARB1F404.43
IADDR=IADDR+LENRIMA ARB1F404.44
ARB1F404.45
24 CONTINUE ARB1F404.46
ARB1F404.47
ELSE ARB1F404.48
ARB1F404.49
! No qcf values available so update with field of zeroes. ARB1F404.50
DO I = 1,LENRIMA ARB1F404.51
TEMP(I) = 0.0 ARB1F404.52
END DO ARB1F404.53
DO 25 LEVEL=1,Q_LEVELS ARB1F404.54
ARB1F404.55
*IF -DEF,MPP ARB1F404.56
CALL MERGEFLD(ROW_LENGTH,ROW_LENGTH,P_ROWS,RIMWIDTHA, ARB1F404.57
& RIMWEIGHTSA,TEMP,D1(JQCF(LEVEL))) ARB1F404.58
*ELSE ARB1F404.59
CALL MPP_MERGEFLD(ROW_LENGTH,P_ROWS, ARB1F404.60
& LENRIMA,RIMWIDTHA,RIMWEIGHTSA, ARB1F404.61
& fld_type_p,TEMP,D1(JQCF(LEVEL))) ARB1F404.62
*ENDIF ARB1F404.63
! Don't alter IADDR here. ARB1F404.64
25 CONTINUE ARB1F404.65
END IF ! L_LSPICE_BDY ARB1F404.66
ARB1F404.67
*IF DEF,MPP APB4F401.59
! We must correct the halos of all the fields with new numbers in their APB4F401.60
! outer points. APB4F401.61
CALL SWAPBOUNDS(D1(JPSTAR),ROW_LENGTH,P_ROWS,Offx,Offy,1) APB4F401.64
CALL SWAPBOUNDS(D1(JU(1)),ROW_LENGTH,P_ROWS,Offx,Offy,P_LEVELS) APB4F401.66
CALL SWAPBOUNDS(D1(JV(1)),ROW_LENGTH,P_ROWS,Offx,Offy,P_LEVELS) APB4F401.68
CALL SWAPBOUNDS(D1(JTHETA(1)),ROW_LENGTH,P_ROWS,Offx,Offy, APB4F401.70
& P_LEVELS) APB4F401.71
CALL SWAPBOUNDS(D1(JQ(1)),ROW_LENGTH,P_ROWS,Offx,Offy,Q_LEVELS) APB4F401.74
IF (TR_VARS.gt.0) THEN ARB1F404.68
DO VAR=1,TR_VARS APB4F401.76
CALL SWAPBOUNDS(D1(JTRACER(1,VAR)),ROW_LENGTH,P_ROWS,Offx,Offy, GPB0F405.127
& TR_LEVELS) APB4F401.78
ENDDO APB4F401.81
END IF ARB1F404.69
IF (L_LSPICE) THEN ARB1F404.70
CALL SWAPBOUNDS(D1(JQCF(1)),ROW_LENGTH,P_ROWS,Offx,Offy,Q_LEVELS) ARB1F404.71
END IF ARB1F404.72
*ENDIF APB4F401.82
RETURN BOUNDVA1.144
END BOUNDVA1.145
BOUNDVA1.146
BOUNDVA1.147
*ENDIF BOUNDVA1.148