SUBROUTINE STATE(TX,SX,RHO,TQ,SQ,IMT,KM,J,JMT) 5,2ORH7F404.34
! ORH1F305.4926
!======================================================================= ORH1F305.4927
! === ORH1F305.4928
! STATE COMPUTES ONE ROW OF NORMALIZED DENSITIES BY USING A 3RD === ORH1F305.4929
! ORDER POLYNOMIAL FIT TO THE KNUDSEN FORMULA, LEVEL BY === ORH1F305.4930
! LEVEL, WHERE: === ORH1F305.4931
! TX =THE INPUT ROW OF TEMPERATURES === ORH1F305.4932
! SX =THE INPUT ROW OF SALINITIES (UNITS: (PPT-35)/1000) === ORH1F305.4933
! RHO=THE RETURNED ROW OF NORMALIZED DENSITIES === ORH1F305.4934
! TQ =ONE ROW OF WORK SPACE PROVIDED BY THE CALLING ROUTINE === ORH1F305.4935
! SQ =ONE ROW OF WORK SPACE PROVIDED BY THE CALLING ROUTINE === ORH1F305.4936
! === ORH1F305.4937
! ORH1F305.4938
! Model Modification history from model version 3.4: ORH1F305.4939
! version Date ORH1F305.4940
! 3.4 16/6/94 : Change CHARACTER*(*) to CHARACTER*(80) N.Farnon ORH1F305.4941
! 4.4 15/08/97 Remove SKIPLAND code. R. Hill ORH7F404.35
! ORH1F305.4942
!======================================================================= ORH1F305.4943
! ORH1F305.4944
IMPLICIT NONE ORH1F305.4945
!--------------------------------------------------------------------- ORH1F305.4946
! DEFINE GLOBAL DATA ORH1F305.4947
!--------------------------------------------------------------------- ORH1F305.4948
! ORH1F305.4949
*CALL OARRYSIZ 
ORH6F401.19
INTEGER ORH1F305.4950
& IMT ! In Number of points in row ORH1F305.4951
&,KM ! Number of levels ORH1F305.4952
&,JMT ! IN No of rows ORH1F305.4953
&,J ! IN ROW NUMBER ORH1F305.4954
ORH1F305.4962
! ORH1F305.4963
*CALL COCSTATE ORH1F305.4964
*CALL CNTLOCN ORH1F305.4965
*CALL OTIMER ORH1F305.4967
!---------------------------------------------------------------------- ORH1F305.4968
! DEFINE LOCAL DATA ORH1F305.4969
!---------------------------------------------------------------------- ORH1F305.4970
INTEGER I, ! Grid point index (Zonal) ORH1F305.4971
& K ! Grid point index (Vertical TOP DOWN) ORH1F305.4972
! ORH1F305.4973
! ORH1F305.4974
!--------------------------------------------------------------------- ORH1F305.4975
! DEMENSION LOCAL DATA ORH1F305.4976
!--------------------------------------------------------------------- ORH1F305.4977
! ORH1F305.4978
REAL TX(IMT,KM),SX(IMT,KM),RHO(IMT,KM),TQ(IMT,KM),SQ(IMT,KM) ORH1F305.4979
ORH1F305.4980
INTEGER LL ! LOOP COUNTER ORH1F305.4981
ORH1F305.4982
! REAL sigo(KM) ! Depth-dependent constant usually left off density ORH1F305.4983
! by STATE but needed when K-theory mixing used ORH1F305.4984
! ORH1F305.4985
! N.B.!!! sigo does not seem to make any difference to the answers ORH1F305.4986
! produced with K-theory mixing. However it was present on ORH1F305.4987
! the Cyber version and has therefore been left in the ORH1F305.4988
! basecode (but with all references to sigo commented out), ORH1F305.4989
! in case anyone remembers why it was there. RAW 24/7/91. ORH1F305.4990
! ORH1F305.4991
! ORH1F305.4992
!--------------------------------------------------------------------- ORH1F305.4993
! ENTER NORMALIZING TEMPERATURES AND SALINITIES, ORH1F305.4994
! AND COEFFICIENTS GENERATED BY THE PROGRAM ("KNUDSN") WHICH ORH1F305.4995
! FITS 3RD ORDER POLYNOMIALS TO THE KNUDSEN FORMULA, LEVEL BY LEVEL. ORH1F305.4996
!--------------------------------------------------------------------- ORH1F305.4997
! ORH1F305.4998
! ORH1F305.4999
!--------------------------------------------------------------------- ORH1F305.5000
! BEGIN EXECUTABLE CODE ORH1F305.5001
!--------------------------------------------------------------------- ORH1F305.5002
IF (L_OTIMER) THEN ORH1F305.5003
CALL TIMER('STATE ',103) GPB8F405.113
ENDIF ORH1F305.5005
! ORH1F305.5006
!--------------------------------------------------------------------- ORH1F305.5007
! SUBTRACT NORMALIZING CONSTANTS FROM TEMPERATURE AND SALINITY ORH1F305.5008
! AND COMPUTE POLYNOMIAL APPROXIMATION OF KNUDSEN DENSITY. ORH1F305.5009
! (..NOTE.. FOR PRECISION PURPOSES, THERE IS A CONSTANT SUBTRACTED ORH1F305.5010
! FROM THE DENSITY RETURNED BY THIS ROUTINE. THIS MAKES NO DIFFERENCE ORH1F305.5011
! HOWEVER, SINCE ONLY HORIZONTAL GRADIENTS ARE USED BY THE MODEL.) ORH1F305.5012
!--------------------------------------------------------------------- ORH1F305.5013
! ORH1F305.5014
DO K=1,KM ORH7F404.36
DO I=1,IMT ORH1F305.5033
TQ(I,K)=TX(I,K)-TO(K) ORH1F305.5034
SQ(I,K)=SX(I,K)-SO(K) ORH1F305.5035
RHO(I,K)=(C(K,1)+(C(K,4)+C(K,7)*SQ(I,K))*SQ(I,K) ORH1F305.5036
& +(C(K,3)+C(K,8)*SQ(I,K)+C(K,6)*TQ(I,K))*TQ(I,K)) ORH1F305.5037
& *TQ(I,K)+(C(K,2)+(C(K,5)+C(K,9) ORH1F305.5038
& *SQ(I,K))*SQ(I,K))*SQ(I,K) ORH1F305.5039
! IF (L_ORICHARD) THEN ORH1F305.5040
! RHO(I,K) = RHO(I,K)+sigo(K) ORH1F305.5041
! ENDIF ORH1F305.5042
ENDDO ! over I ORH1F305.5043
ENDDO ! over K ORH7F404.37
ORH1F305.5046
IF (L_OTIMER) THEN ORH1F305.5047
CALL TIMER('STATE ',104) GPB8F405.114
ENDIF ORH1F305.5049
RETURN ORH1F305.5050
END ORH1F305.5051
! ORH1F305.5052
SUBROUTINE STATEC(TX,SX,RHO,TQ,SQ,IND,IMT,KM,J,JMT) 21,2ORH7F404.38
! ORH1F305.5057
IMPLICIT NONE ORH1F305.5058
*CALL OARRYSIZ ORH6F401.20
*CALL COCSTATE ORH1F305.5059
*CALL CNTLOCN ORH1F305.5060
*CALL OTIMER ORH1F305.5062
!--------------------------------------------------------------------- ORH1F305.5063
! DEFINE GLOBAL DATA ORH1F305.5064
!--------------------------------------------------------------------- ORH1F305.5065
! ORH1F305.5066
INTEGER ORH1F305.5067
& IMT ! IN Number of points in row ORH1F305.5068
&,KM ! Number of levels ORH1F305.5069
&,JMT ! IN No of rows ORH1F305.5070
&,J ! IN ROW NUMBER ORH1F305.5071
! ORH1F305.5079
! ORH1F305.5080
!--------------------------------------------------------------------- ORH1F305.5081
! DEMENSION LOCAL DATA ORH1F305.5082
!--------------------------------------------------------------------- ORH1F305.5083
! ORH1F305.5084
REAL TX(IMT,KM),SX(IMT,KM),RHO(IMT,KM),TQ(IMT,KM),SQ(IMT,KM) ORH1F305.5085
INTEGER LL ! SEGMENT COUNTER ORH1F305.5086
INTEGER IND ORH1F305.5087
&, I, ! Grid point index (Zonal) ORH1F305.5088
& L ! Ocean level loop control ORH1F305.5089
! ORH1F305.5090
!======================================================================= ORH1F305.5091
! === ORH1F305.5092
! STATEC COMPUTES, FOR ONE ROW, THE NORMALIZED DENSITIES BY USING === ORH1F305.5093
! A 3RD ORDER POLYNOMIAL FIT TO THE KNUDSEN FORMULA, FOR === ORH1F305.5094
! PURPOSES OF CHECKING VERTICAL STABILITY BETWEEN ADJACENT === ORH1F305.5095
! LEVELS. THE REFERENCE DEPTH FOR PRESSURE DEPENDENCE IN === ORH1F305.5096
! THE KNUDSEN FORMULA MUST BE HELD CONSTANT FOR THIS PURPOSE.=== ORH1F305.5097
! THAT LEVEL IS DETERMINED BY "IND". THE ARGUMENTS ARE: === ORH1F305.5098
! TX =THE INPUT ROW OF TEMPERATURES === ORH1F305.5099
! SX =THE INPUT ROW OF SALINITIES (UNITS: (PPT-35)/1000) === ORH1F305.5100
! RHO=THE RETURNED ROW OF NORMALIZED DENSITIES === ORH1F305.5101
! TQ =ONE ROW OF WORK SPACE PROVIDED BY THE CALLING ROUTINE === ORH1F305.5102
! SQ =ONE ROW OF WORK SPACE PROVIDED BY THE CALLING ROUTINE === ORH1F305.5103
! IND=1 FOR COMPARING LEVELS 1 TO 2, 3 TO 4, ETC. === ORH1F305.5104
! --COEFFICIENTS FOR THE LOWER OF THE 2 LEVELS ARE USED === ORH1F305.5105
! IND=2 FOR COMPARING LEVELS 2 TO 3, 4 TO 5, ETC. === ORH1F305.5106
! --COEFFICIENTS FOR THE LOWER OF THE 2 LEVELS ARE USED === ORH5F400.35
! --(NOT THE UPPER LEVEL AS STATED IN ORIGINAL COX CODE) === ORH5F400.36
! === ORH1F305.5108
!======================================================================= ORH1F305.5109
! ORH1F305.5110
IF (L_OTIMER) THEN ORH1F305.5111
CALL TIMER('STATEC ',103) GPB8F405.115
ENDIF ORH1F305.5113
DO L=1,KM ORH7F404.39
DO I=1,IMT ORH1F305.5129
TQ(I,L)=TX(I,L)-TOI(L,IND) ORH1F305.5130
SQ(I,L)=SX(I,L)-SOI(L,IND) ORH1F305.5131
RHO(I,L)=(CI(L,1,IND)+(CI(L,4,IND)+CI(L,7,IND) ORH1F305.5132
& *SQ(I,L))*SQ(I,L)+(CI(L,3,IND)+CI(L,8,IND)*SQ(I,L) ORH1F305.5133
& +CI(L,6,IND)*TQ(I,L))*TQ(I,L))*TQ(I,L)+(CI(L,2,IND) ORH1F305.5134
& +(CI(L,5,IND)+CI(L,9,IND)*SQ(I,L))*SQ(I,L))*SQ(I,L) ORH1F305.5135
ENDDO ! over I ORH1F305.5136
ENDDO ! over L ORH7F404.40
ORH1F305.5139
IF (L_OTIMER) THEN ORH1F305.5140
CALL TIMER('STATEC ',104) GPB8F405.116
ENDIF ORH1F305.5142
RETURN ORH1F305.5143
END ORH1F305.5144
! ORH1F305.5145
SUBROUTINE STATED(TX,SX,RHO,TQ,SQ,IMT,MAX_LEV,J,KM,JMT) 18,2ORH7F404.41
! ORH1F305.5152
!======================================================================= ORH1F305.5153
! = ORH1F305.5154
! STATED = ORH1F305.5155
! = ORH1F305.5156
! STATED uses surface coefficients to calculate the density at however = ORH1F305.5157
! many vertical levels are required by the user. This is currently = ORH1F305.5158
! (Feb. 1991) used by mixed layer, K-theory mixing and thermodynamic = ORH1F305.5159
! ice. = ORH1F305.5160
! = ORH1F305.5161
! TX = Input row of temperatures = ORH1F305.5162
! SX = Input row of salinities = ORH1F305.5163
! RHO = Returned row of normalised densities = ORH1F305.5164
! TQ,SQ = Two rows of workspace, provided by calling routine = ORH1F305.5165
! MAX_LEV = The number of vertical levels at which the calculation = ORH1F305.5166
! is to be done (starts at top level) = ORH1F305.5167
! = ORH1F305.5168
! HISTORY: ORH1F305.5169
! VERSION DATE DESCRIPTION ORH1F305.5170
! ------- -------- ------------------------------------- ORH1F305.5171
! 3.4 28.01.94 MAKE CALL TO TIMER CONDITIONAL. R.Hill ORH1F305.5172
!======================================================================= ORH1F305.5173
! ORH1F305.5174
IMPLICIT NONE ORH1F305.5175
! ORH1F305.5176
!--------------------------------------------------------------------- ORH1F305.5177
! DEFINE GLOBAL DATA ORH1F305.5178
!--------------------------------------------------------------------- ORH1F305.5179
! ORH1F305.5180
*CALL COCSTATE ORH1F305.5181
*CALL CNTLOCN ORH1F305.5182
*CALL OTIMER ORH1F305.5183
*CALL OARRYSIZ ORH1F305.5184
INTEGER ORH1F305.5185
& IMT ! IN Number of points in row ORH1F305.5186
&,KM ! IN Number of levels ORH1F305.5187
&,JMT ! IN No of rows ORH1F305.5188
&,J ! IN ROW NUMBER ORH1F305.5189
! ORH1F305.5197
! ORH1F305.5198
!--------------------------------------------------------------------- ORH1F305.5199
! DEMENSION LOCAL DATA ORH1F305.5200
!--------------------------------------------------------------------- ORH1F305.5201
! ORH1F305.5202
INTEGER MAX_LEV ORH1F305.5203
&, I ! Grid point index (Zonal) ORH1F305.5204
&, K ! Grid point index (Vertical TOP DOWN) ORH1F305.5205
&, M ! Tracer indicator ORH1F305.5206
REAL TX(IMT,MAX_LEV),SX(IMT,MAX_LEV),RHO(IMT,MAX_LEV) ORH1F305.5207
REAL TQ(IMT,MAX_LEV),SQ(IMT,MAX_LEV) ORH1F305.5208
ORH1F305.5209
INTEGER LL ! SEGMENT COUNTER ORH1F305.5210
! ORH1F305.5211
IF (L_OTIMER) THEN ORH1F305.5212
CALL TIMER('STATED ',103) GPB8F405.117
ENDIF ORH1F305.5214
ORH1F305.5215
M=1 ORH1F305.5216
DO K=1,MAX_LEV ORH7F404.42
DO I=1,IMT ORH1F305.5232
TQ(I,K)=TX(I,K)-TO(M) ORH1F305.5233
SQ(I,K)=SX(I,K)-SO(M) ORH1F305.5234
RHO(I,K)=(C(M,1)+(C(M,4)+C(M,7)*SQ(I,K))*SQ(I,K) ORH1F305.5235
& +(C(M,3)+C(M,8)*SQ(I,K)+C(M,6)*TQ(I,K))*TQ(I,K)) ORH1F305.5236
& *TQ(I,K)+(C(M,2)+(C(M,5)+C(M,9)*SQ(I,K)) ORH1F305.5237
& *SQ(I,K))*SQ(I,K) ORH1F305.5238
ENDDO ! K ORH1F305.5239
ENDDO ! I ORH7F404.43
ORH1F305.5241
IF (L_OTIMER) THEN ORH1F305.5243
CALL TIMER('STATED ',104) GPB8F405.118
ENDIF ORH1F305.5245
ORH1F305.5246
RETURN ORH1F305.5247
END ORH1F305.5248
SUBROUTINE STATE_T(TX,SX,Temperature,TQ,SQ,IMT,KM 1,2OMB1F404.39
&,J,JMT OMB1F404.40
& ) OMB1F404.41
! OMB1F404.42
!======================================================================= OMB1F404.43
! === OMB1F404.44
! STATE_T COMPUTES ONE ROW OF TEMPERATURES BY USING A 3RD === OMB1F404.45
! ORDER POLYNOMIAL FIT TO THE KNUDSEN FORMULA, LEVEL BY === OMB1F404.46
! LEVEL, WHERE: === OMB1F404.47
! TX =THE INPUT ROW OF POTENTIAL TEMPERATURES === OMB1F404.48
! SX =THE INPUT ROW OF SALINITIES (UNITS: (PPT-35)/1000) === OMB1F404.49
! Temperature=THE RETURNED ROW OF temperatures === OMB1F404.50
! TQ =ONE ROW OF WORK SPACE PROVIDED BY THE CALLING ROUTINE === OMB1F404.51
! SQ =ONE ROW OF WORK SPACE PROVIDED BY THE CALLING ROUTINE === OMB1F404.52
! === OMB1F404.53
! OMB1F404.54
! Model Modification history from model version 3.4: OMB1F404.55
! version Date OMB1F404.56
! 4.4 20/5/97 : New routine to enable temperature (rather than OMB1F404.57
! theta to be output to stash) M. J. Bell OMB1F404.58
! OMB1F404.59
!======================================================================= OMB1F404.60
! OMB1F404.61
IMPLICIT NONE OMB1F404.62
!--------------------------------------------------------------------- OMB1F404.63
! DEFINE GLOBAL DATA OMB1F404.64
!--------------------------------------------------------------------- OMB1F404.65
! OMB1F404.66
INTEGER OMB1F404.67
& IMT ! In Number of points in row OMB1F404.68
&,KM ! Number of levels OMB1F404.69
&,JMT ! IN No of rows OMB1F404.70
&,J ! IN ROW NUMBER OMB1F404.71
OMB1F404.72
! OMB1F404.73
*CALL COCSTATE OMB1F404.74
*CALL CNTLOCN OMB1F404.75
*CALL OTIMER OMB1F404.76
!---------------------------------------------------------------------- OMB1F404.77
! DEFINE LOCAL DATA OMB1F404.78
!---------------------------------------------------------------------- OMB1F404.79
INTEGER I, ! Grid point index (Zonal) OMB1F404.80
& K ! Grid point index (Vertical TOP DOWN) OMB1F404.81
! OMB1F404.82
! OMB1F404.83
!--------------------------------------------------------------------- OMB1F404.84
! DEMENSION LOCAL DATA OMB1F404.85
!--------------------------------------------------------------------- OMB1F404.86
! OMB1F404.87
REAL TX(IMT,KM),SX(IMT,KM),Temperature(IMT,KM) OMB1F404.88
REAL TQ(IMT,KM),SQ(IMT,KM) OMB1F404.89
OMB1F404.90
INTEGER LL ! LOOP COUNTER OMB1F404.91
OMB1F404.92
! REAL sigo(KM) ! Depth-dependent constant usually left off density OMB1F404.93
! by STATE but needed when K-theory mixing used OMB1F404.94
! OMB1F404.95
!--------------------------------------------------------------------- OMB1F404.96
! BEGIN EXECUTABLE CODE OMB1F404.97
!--------------------------------------------------------------------- OMB1F404.98
IF (L_OTIMER) THEN OMB1F404.99
CALL TIMER('STATE_T ',103) GPB8F405.119
ENDIF OMB1F404.101
! OMB1F404.102
!--------------------------------------------------------------------- OMB1F404.103
! SUBTRACT NORMALIZING CONSTANTS FROM TEMPERATURE AND SALINITY OMB1F404.104
! AND COMPUTE POLYNOMIAL APPROXIMATION OF Temperature. OMB1F404.105
!--------------------------------------------------------------------- OMB1F404.106
! OMB1F404.107
DO K=1,KM OMB1F404.108
DO I=1,IMT OMB1F404.109
TQ(I,K)=TX(I,K)-TO(K) OMB1F404.110
SQ(I,K)=SX(I,K)-SO(K) OMB1F404.111
OMB1F404.112
Temperature(I,K)= TempO(K) + OMB1F404.113
& OMB1F404.114
& TQ(I,K) * ( coeff_T(K,1) + OMB1F404.115
& ( coeff_T(K,4) + coeff_T(K,7)*SQ(I,K) ) * SQ(I,K) OMB1F404.116
& + ( coeff_T(K,3) + coeff_T(K,8)*SQ(I,K) OMB1F404.117
& + coeff_T(K,6)*TQ(I,K) ) * TQ(I,K) ) OMB1F404.118
& OMB1F404.119
& + SQ(I,K) * ( coeff_T(K,2) + OMB1F404.120
& ( coeff_T(K,5) + coeff_T(K,9)*SQ(I,K) ) * SQ(I,K) ) OMB1F404.121
OMB1F404.122
ENDDO ! over I OMB1F404.123
ENDDO ! over K OMB1F404.124
OMB1F404.125
IF (L_OTIMER) THEN OMB1F404.126
CALL TIMER('STATE_T ',104) GPB8F405.120
ENDIF OMB1F404.128
RETURN OMB1F404.129
END OMB1F404.130
SUBROUTINE STINIT (KM, ICODE, CMESSAGE) 1,2ORH1F305.5249
! ORH1F305.5250
!======================================================================= ORH1F305.5251
! === ORH1F305.5252
! STINIT LOADS THE APPROPRIATE NORMALIZATION CONSTANTS AND COEF- === ORH1F305.5253
! FICIENTS INTO ARRAYS OF PROPER DIMENSION TO PERMIT VEC- === ORH1F305.5254
! TORIZATION IN THE SUBSEQUENT CALLS TO "STATE" AND "STATEC" === ORH1F305.5255
! === ORH1F305.5256
!======================================================================= ORH1F305.5257
! ORH1F305.5258
IMPLICIT NONE ORH1F305.5259
*CALL COCSTATE ORH1F305.5260
*CALL CNTLOCN ORH1F305.5261
*CALL OARRYSIZ ORH1F305.5262
*CALL OTIMER ORH1F305.5263
! ORH1F305.5264
INTEGER KM ! Number of levels in model ORH1F305.5265
INTEGER ICODE ! Error code ORH1F305.5266
&, JND ! Index used in loading coefficients ORH1F305.5267
&, K ! Grid point index (Vertical) ORH1F305.5268
&, KREF ! Reference level indicator ORH1F305.5269
&, N ! Control index ORH1F305.5270
CHARACTER*(80) CMESSAGE ORH1F305.5271
! ORH1F305.5272
!--------------------------------------------------------------------- ORH1F305.5273
! LOAD COEFFICIENTS FOR USE IN STATE ORH1F305.5274
!--------------------------------------------------------------------- ORH1F305.5275
! ORH1F305.5276
IF (L_OTIMER) THEN ORH1F305.5277
CALL TIMER('STINIT ',103) GPB8F405.121
ENDIF ORH1F305.5279
! ORH1F305.5280
! Check arrays are big enough ORH1F305.5281
! ORH1F305.5282
IF (MAXLEV .LT. KM ) THEN ORH1F305.5283
ICODE=300 ORH1F305.5284
CMESSAGE='Error in STINIT: too many levels in model' ORH1F305.5285
END IF ORH1F305.5286
! ORH1F305.5287
!--------------------------------------------------------------------- ORH1F305.5288
! LOAD COEFFICIENTS FOR USE IN STATEC. ORH1F305.5289
! DETERMINE THE REFERENCE LEVEL INDICATOR, "KREF" IN ACCORD WITH ORH1F305.5290
! COMMENT ON "IND" IN INTRODUCTORY STATEMENT FOR SUBROUTINE STATEC. ORH1F305.5291
!--------------------------------------------------------------------- ORH1F305.5292
! ORH1F305.5293
DO JND=1,2 ORH1F305.5294
IF (L_OFILTER) THEN ORH1F305.5295
CFPP$ SELECT (CONCUR) ORH1F305.5296
DO K=1,KM,2 ORH1F305.5297
IF (JND.EQ.1) THEN ORH1F305.5298
KREF=K+1 ORH1F305.5299
IF(KREF.GT.KM) KREF=KM ORH1F305.5300
ELSE ORH1F305.5301
KREF=K ORH1F305.5302
ENDIF ORH1F305.5303
TOI (K,JND)=TO (KREF) ORH1F305.5304
SOI (K,JND)=SO (KREF) ORH1F305.5305
DO N=1,9 ORH1F305.5306
CI (K,N,JND)=C (KREF,N) ORH1F305.5307
ENDDO ! N ORH1F305.5308
ENDDO ! K ORH1F305.5309
CFPP$ SELECT (CONCUR) ORH1F305.5310
DO K=2,KM,2 ORH1F305.5311
IF (JND.EQ.2) THEN ORH1F305.5312
KREF=K+1 ORH1F305.5313
IF(KREF.GT.KM) KREF=KM ORH1F305.5314
ELSE ORH1F305.5315
KREF=K ORH1F305.5316
ENDIF ORH1F305.5317
TOI (K,JND)=TO (KREF) ORH1F305.5318
SOI (K,JND)=SO (KREF) ORH1F305.5319
DO N=1,9 ORH1F305.5320
CI (K,N,JND)=C (KREF,N) ORH1F305.5321
ENDDO ! N ORH1F305.5322
ENDDO ! K ORH1F305.5323
ELSE ! Not L_OFILTER ORH1F305.5324
DO K=1,KM,2 ORH1F305.5325
IF (JND.EQ.1) THEN ORH1F305.5326
KREF=K+1 ORH1F305.5327
IF(KREF.GT.KM) KREF=KM ORH1F305.5328
ELSE ORH1F305.5329
KREF=K ORH1F305.5330
ENDIF ORH1F305.5331
TOI (K,JND)=TO (KREF) ORH1F305.5332
SOI (K,JND)=SO (KREF) ORH1F305.5333
DO N=1,9 ORH1F305.5334
CI (K,N,JND)=C (KREF,N) ORH1F305.5335
ENDDO ! over N ORH1F305.5336
ENDDO ! over K ORH1F305.5337
ORH1F305.5338
DO K=2,KM,2 ORH1F305.5339
IF (JND.EQ.2) THEN ORH1F305.5340
KREF=K+1 ORH1F305.5341
IF(KREF.GT.KM) KREF=KM ORH1F305.5342
ELSE ORH1F305.5343
KREF=K ORH1F305.5344
ENDIF ORH1F305.5345
TOI (K,JND)=TO (KREF) ORH1F305.5346
SOI (K,JND)=SO (KREF) ORH1F305.5347
DO N=1,9 ORH1F305.5348
CI (K,N,JND)=C (KREF,N) ORH1F305.5349
ENDDO ! over N ORH1F305.5350
ENDDO ! over K ORH1F305.5351
ENDIF ORH1F305.5352
ENDDO ! over JND ORH1F305.5353
IF (L_OTIMER) THEN ORH1F305.5354
CALL TIMER('STINIT ',104) GPB8F405.122
ENDIF ORH1F305.5356
RETURN STATE.233
END STATE.234
*ENDIF @DYALLOC.4146