c Minor fixes to resolve warnings issued by the g95 Fortran compiler. c SJP 2009/04/14 c c Major tidy-up of the ocean model source code. c SJP 2007/06/17 c c Added IMPLICIT NONE statement, plus variable declarations as necessary. c SJP 2007/05/30 c c Transferred COMMON block declarations to separate header files. c SJP 2007/05/29 c c Modified for changes to /WORKSP/. c SJP 2003/09/04 c c Parameter definitions moved to include file OPARAMS.f. c SJP 2003/04/29 c c $Log: state.f,v $ c Revision 1.6 1997/12/19 01:25:32 ldr c Changes from ACH for 21 OGCM levels and optinal GM mixing scheme... c c Change to 21 levels in ocean model, and insertion of c eddy-induced transport (major changes delineated) c c Revision 1.5 1994/03/30 12:35:03 ldr c Changes to V4-5 from HBG and SPO for coupled and qflux runs c c Revision 1.4 93/12/17 15:33:48 ldr c Hack V4-4-52l to change all continuation chars to & c c Revision 1.3 93/10/05 13:07:31 ldr c Changes to V4-4-15l from HBG for T63 and coupled model c c Revision 1.2 93/07/12 14:15:02 ldr c Minor changes from SPO for coupled model V4-4. c c Revision 1.1 93/02/05 16:22:28 ldr c Initial revision c SUBROUTINE STATE(TX,SX,RHO,TQ,SQ) C C======================================================================= C === C STATE COMPUTES ONE ROW OF NORMALIZED DENSITIES BY USING A 3RD === C ORDER POLYNOMIAL FIT TO THE KNUDSEN FORMULA, LEVEL BY === C LEVEL, WHERE: === C TX =THE INPUT ROW OF TEMPERATURES === C SX =THE INPUT ROW OF SALINITIES (UNITS: (PPT-35)/1000) === C RHO=THE RETURNED ROW OF NORMALIZED DENSITIES === C TQ =ONE ROW OF WORK SPACE PROVIDED BY THE CALLING ROUTINE === C SQ =ONE ROW OF WORK SPACE PROVIDED BY THE CALLING ROUTINE === C === C======================================================================= C implicit none C C--------------------------------------------------------------------- C DEFINE GLOBAL DATA C--------------------------------------------------------------------- C include 'OPARAMS.f' include 'WORKSP.f' C C--------------------------------------------------------------------- C DEMENSION LOCAL DATA C--------------------------------------------------------------------- C integer i, k, l, n, ind, jnd, kref real tx, sx, rho, tq, sq, to, so, c DIMENSION TX(IMT,KM),SX(IMT,KM),RHO(IMT,KM),TQ(IMT,KM),SQ(IMT,KM) DIMENSION TO(KM),SO(KM),C(KM,9) C C--------------------------------------------------------------------- C ENTER NORMALIZING TEMPERATURES AND SALINITIES, C AND COEFFICIENTS GENERATED BY THE PROGRAM ("KNUDSN") WHICH C FITS 3RD ORDER POLYNOMIALS TO THE KNUDSEN FORMULA, LEVEL BY LEVEL. C--------------------------------------------------------------------- C C C ..................................................... begin .. ach .. 9/2/95 data to/ * 13.4982640,13.4947868,13.4909537,13.4862728,13.4806671, * 13.4741279,13.4663623, 8.4671729, 8.4563053, 5.9517591, * 5.9362940, 4.4277700, 3.6643956, 2.6523479, 2.6250452, * 2.5889155, 2.5459267, 2.5000261, 2.4512988, 2.3998300, * 2.3457048/ data so/ * -0.0022500,-0.0022500,-0.0022500,-0.0022500,-0.0022500, * -0.0022500,-0.0022500, 0.0001500, 0.0001500,-0.0001000, * -0.0001000,-0.0001000,-0.0002500,-0.0002500,-0.0002000, * -0.0002000,-0.0002000,-0.0002000,-0.0002000,-0.0002000, * -0.0002000/ data (c( 1,n),n=1,9)/ * -.2018685E-03,0.7709554E+00,-.4916543E-05,-.2007910E-02, * 0.4496054E+00,0.3653600E-07,0.4726250E-02,0.3768814E-04, * 0.6548289E+01/ data (c( 2,n),n=1,9)/ * -.2023356E-03,0.7707884E+00,-.4908773E-05,-.2005534E-02, * 0.4496990E+00,0.3645055E-07,0.4717484E-02,0.3764477E-04, * 0.6547356E+01/ data (c( 3,n),n=1,9)/ * -.2028490E-03,0.7706047E+00,-.4900234E-05,-.2002918E-02, * 0.4497997E+00,0.3635621E-07,0.4707871E-02,0.3759710E-04, * 0.6546329E+01/ data (c( 4,n),n=1,9)/ * -.2034738E-03,0.7703811E+00,-.4889841E-05,-.1999728E-02, * 0.4499194E+00,0.3624078E-07,0.4696201E-02,0.3753908E-04, * 0.6545079E+01/ data (c( 5,n),n=1,9)/ * -.2042188E-03,0.7701143E+00,-.4877445E-05,-.1995913E-02, * 0.4500579E+00,0.3610226E-07,0.4682324E-02,0.3746987E-04, * 0.6543585E+01/ data (c( 6,n),n=1,9)/ * -.2050835E-03,0.7698044E+00,-.4863054E-05,-.1991472E-02, * 0.4502130E+00,0.3594025E-07,0.4666274E-02,0.3738952E-04, * 0.6541848E+01/ data (c( 7,n),n=1,9)/ * -.2061045E-03,0.7694382E+00,-.4846060E-05,-.1986211E-02, * 0.4503884E+00,0.3574728E-07,0.4647401E-02,0.3729463E-04, * 0.6539793E+01/ data (c( 8,n),n=1,9)/ * -.1633825E-03,0.7809512E+00,-.5274764E-05,-.2321958E-02, * 0.7150230E+00,0.4941191E-07,0.5146337E-02,0.3858534E-04, * 0.6612295E+01/ data (c( 9,n),n=1,9)/ * -.1655789E-03,0.7802307E+00,-.5238971E-05,-.2310480E-02, * 0.7020086E+00,0.4914798E-07,0.5119267E-02,0.3844090E-04, * 0.6608791E+01/ data (c(10,n),n=1,9)/ * -.1415738E-03,0.7850452E+00,-.5558599E-05,-.2486598E-02, * 0.6185962E+00,0.5815748E-07,0.6177066E-02,0.3938672E-04, * 0.6642079E+01/ data (c(11,n),n=1,9)/ * -.1455092E-03,0.7838035E+00,-.5495885E-05,-.2466084E-02, * 0.5741187E+00,0.5780261E-07,0.6141312E-02,0.3918505E-04, * 0.6636308E+01/ data (c(12,n),n=1,9)/ * -.1337803E-03,0.7860551E+00,-.5670631E-05,-.2556539E-02, * 0.3517643E+00,0.6398836E-07,0.7003589E-02,0.3961952E-04, * 0.6655201E+01/ data (c(13,n),n=1,9)/ * -.1306401E-03,0.7861403E+00,-.5717355E-05,-.2586788E-02, * 0.1558243E+00,0.6709557E-07,0.7453718E-02,0.3985948E-04, * 0.6660040E+01/ data (c(14,n),n=1,9)/ * -.1261105E-03,0.7866403E+00,-.5805777E-05,-.2629480E-02, * -.2419014E+00,0.7191460E-07,0.8199666E-02,0.4012509E-04, * 0.6669647E+01/ data (c(15,n),n=1,9)/ * -.1346502E-03,0.7841071E+00,-.5672226E-05,-.2584847E-02, * -.7712622E+00,0.7133655E-07,0.8159743E-02,0.3980031E-04, * 0.6658788E+01/ data (c(16,n),n=1,9)/ * -.1449909E-03,0.7809411E+00,-.5508421E-05,-.2530234E-02, * -.3149313E+01,0.7052185E-07,0.8119250E-02,0.3945833E-04, * 0.6645021E+01/ data (c(17,n),n=1,9)/ * -.1562981E-03,0.7774569E+00,-.5326879E-05,-.2469626E-02, * -.4474242E+01,0.6948068E-07,0.8082081E-02,0.3908818E-04, * 0.6629726E+01/ data (c(18,n),n=1,9)/ * -.1674117E-03,0.7740104E+00,-.5146114E-05,-.2409185E-02, * -.5927316E+01,0.6829648E-07,0.8053621E-02,0.3873002E-04, * 0.6614503E+01/ data (c(19,n),n=1,9)/ * -.1783303E-03,0.7706040E+00,-.4966433E-05,-.2349010E-02, * -.7502986E+01,0.6697004E-07,0.8034380E-02,0.3838566E-04, * 0.6599367E+01/ data (c(20,n),n=1,9)/ * -.1890529E-03,0.7672399E+00,-.4788146E-05,-.2289199E-02, * -.9195753E+01,0.6550253E-07,0.8024873E-02,0.3805696E-04, * 0.6584362E+01/ data (c(21,n),n=1,9)/ * -.1995788E-03,0.7639206E+00,-.4611561E-05,-.2229852E-02, * -.1100017E+02,0.6389548E-07,0.8025626E-02,0.3774584E-04, * 0.6569530E+01/ C ........................................................................ end C C--------------------------------------------------------------------- C BEGIN EXECUTABLE CODE C--------------------------------------------------------------------- C C--------------------------------------------------------------------- C SUBTRACT NORMALIZING CONSTANTS FROM TEMPERATURE AND SALINITY C AND COMPUTE POLYNOMIAL APPROXIMATION OF KNUDSEN DENSITY. C (..NOTE.. FOR PRECISION PURPOSES, THERE IS A CONSTANT SUBTRACTED C FROM THE DENSITY RETURNED BY THIS ROUTINE. THIS MAKES NO DIFFERENCE C HOWEVER, SINCE ONLY HORIZONTAL GRADIENTS ARE USED BY THE MODEL.) C--------------------------------------------------------------------- C DO 100 K=1,KM DO 100 I=1,IMT TQ(I,K)=TX(I,K)-TOQ(I,K) SQ(I,K)=SX(I,K)-SOQ(I,K) RHO(I,K)=(CQ(I,K,1)+(CQ(I,K,4)+CQ(I,K,7)*SQ(I,K))*SQ(I,K) & +(CQ(I,K,3)+CQ(I,K,8)*SQ(I,K)+CQ(I,K,6)*TQ(I,K))*TQ(I,K)) & *TQ(I,K)+(CQ(I,K,2)+(CQ(I,K,5)+CQ(I,K,9) & *SQ(I,K))*SQ(I,K))*SQ(I,K) 100 CONTINUE RETURN C ENTRY STATEC(TX,SX,RHO,TQ,SQ,IND) C C======================================================================= C === C STATEC COMPUTES, FOR ONE ROW, THE NORMALIZED DENSITIES BY USING === C A 3RD ORDER POLYNOMIAL FIT TO THE KNUDSEN FORMULA, FOR === C PURPOSES OF CHECKING VERTICAL STABILITY BETWEEN ADJACENT === C LEVELS. THE REFERENCE DEPTH FOR PRESSURE DEPENDENCE IN === C THE KNUDSEN FORMULA MUST BE HELD CONSTANT FOR THIS PURPOSE.=== C THAT LEVEL IS DETERMINED BY "IND". THE ARGUMENTS ARE: === C TX =THE INPUT ROW OF TEMPERATURES === C SX =THE INPUT ROW OF SALINITIES (UNITS: (PPT-35)/1000) === C RHO=THE RETURNED ROW OF NORMALIZED DENSITIES === C TQ =ONE ROW OF WORK SPACE PROVIDED BY THE CALLING ROUTINE === C SQ =ONE ROW OF WORK SPACE PROVIDED BY THE CALLING ROUTINE === C IND=1 FOR COMPARING LEVELS 1 TO 2, 3 TO 4, ETC. === C --COEFFICIENTS FOR THE LOWER OF THE 2 LEVELS ARE USED === C IND=2 FOR COMPARING LEVELS 2 TO 3, 4 TO 5, ETC. === C --COEFFICIENTS FOR THE LOWER OF THE 2 LEVELS ARE USED === C === C======================================================================= C DO 1100 L=1,KM DO 1100 I=1,IMT TQ(I,L)=TX(I,L)-TOIQ(I,L,IND) SQ(I,L)=SX(I,L)-SOIQ(I,L,IND) RHO(I,L)=(CIQ(I,L,1,IND)+(CIQ(I,L,4,IND)+CIQ(I,L,7,IND) &*SQ(I,L))*SQ(I,L)+(CIQ(I,L,3,IND)+CIQ(I,L,8,IND)*SQ(I,L) &+CIQ(I,L,6,IND)*TQ(I,L))*TQ(I,L))*TQ(I,L)+(CIQ(I,L,2,IND) &+(CIQ(I,L,5,IND)+CIQ(I,L,9,IND)*SQ(I,L))*SQ(I,L))*SQ(I,L) 1100 CONTINUE RETURN C ENTRY STINIT C C======================================================================= C === C STINIT LOADS THE APPROPRIATE NORMALIZATION CONSTANTS AND COEF- === C FICIENTS INTO ARRAYS OF PROPER DIMENSION TO PERMIT VEC- === C TORIZATION IN THE SUBSEQUENT CALLS TO "STATE" AND "STATEC" === C === C======================================================================= C C--------------------------------------------------------------------- C LOAD COEFFICIENTS FOR USE IN STATE C--------------------------------------------------------------------- C DO 10 N=1,9 DO 10 K=1,KM DO 10 I=1,IMT CQ(I,K,N)=C(K,N) 10 CONTINUE DO 20 K=1,KM DO 20 I=1,IMT TOQ(I,K)=TO(K) SOQ(I,K)=SO(K) 20 CONTINUE C C--------------------------------------------------------------------- C LOAD COEFFICIENTS FOR USE IN STATEC. C DETERMINE THE REFERENCE LEVEL INDICATOR, "KREF" IN ACCORD WITH C COMMENT ON "IND" IN INTRODUCTORY STATEMENT FOR ENTRY STATEC. C--------------------------------------------------------------------- C DO 70 JND=1,2 DO 53 K=1,KM,2 IF (JND.EQ.1) THEN KREF=K+1 IF(KREF.GT.KM) KREF=KM ELSE KREF=K ENDIF DO 50 I=1,IMT TOIQ(I,K,JND)=TOQ(I,KREF) SOIQ(I,K,JND)=SOQ(I,KREF) 50 CONTINUE DO 52 N=1,9 DO 52 I=1,IMT CIQ(I,K,N,JND)=CQ(I,KREF,N) 52 CONTINUE 53 CONTINUE DO 63 K=2,KM,2 IF (JND.EQ.2) THEN KREF=K+1 IF(KREF.GT.KM) KREF=KM ELSE KREF=K ENDIF DO 60 I=1,IMT TOIQ(I,K,JND)=TOQ(I,KREF) SOIQ(I,K,JND)=SOQ(I,KREF) 60 CONTINUE DO 62 N=1,9 DO 62 I=1,IMT CIQ(I,K,N,JND)=CQ(I,KREF,N) 62 CONTINUE 63 CONTINUE 70 CONTINUE RETURN END