      SUBROUTINE KELBOW
C
C     THIS ROUTINE COMPUTES THE TWO 6 X 6 MATRICES K(NPVT,NPVT) AND
C     K(NPVT,J) FOR A CURVED BAR ELEMENT HAVING END POINTS NUMBERED
C     NPVT AND J
C
C                   ECPT FOR THE ELBOW
C
C     ECPT( 1)  -  IELID         ELEMENT ID. NUMBER
C     ECPT( 2)  -  ISILNO(2)     * SCALAR INDEX NOS. OF THE GRID POINTS
C     ECPT( 3)  -    ...         *
C     ECPT( 4)  -  SMALLV(3)     $ REFERENCE VECTOR
C     ECPT( 5)  -    ...         $
C     ECPT( 6)  -    ...         $
C     ECPT( 7)  -  ICSSV         COOR. SYS. ID FOR SMALLV VECTOR
C     ECPT( 8)  -  IMATID        MATERIAL ID.
C     ECPT( 9)  -  A             CROSS-SECTIONAL AREA
C     ECPT(10)  -  I1            $ AREA MOMENTS OF INERTIA
C     ECPT(11)  -  I2            $
C     ECPT(12)  -  FJ            TORSIONAL CONSTANT
C     ECPT(13)  -  NSM           NON-STRUCTURAL MASS
C     ECPT(14)  -  FE            FORCE ELEM. DESCRIPTIONS, FORCE METHOD
C     ECPT(15)  -  R1            *STRESS RECOVERY COEFFICIENTS
C     ECPT(16)  -  T1            *  RI = RADIAL  LOCATION
C     ECPT(17)  -  R2            *  TI = ANGULAR LOCATION
C     ECPT(18)  -  T2            *       OF STRESS RECOVERY POINTS
C     ECPT(19)  -  R3            *
C     ECPT(20)  -  T3            *
C     ECPT(21)  -  R4            *
C     ECPT(22)  -  T4            *
C     ECPT(23)  -  K1            $  AREA FACTOR FOR SHEAR
C     ECPT(24)  -  K2            $
C     ECPT(25)  -  C             STRESS INTENSIFICATION FACTOR
C     ECPT(26)  -  KX            *  FLEXIBILITY CORRECTION FACTORS
C     ECPT(27)  -  KY            *
C     ECPT(28)  -  KZ            *
C     ECPT(29)  -  R             RADIUS OF CURVATURE
C     ECPT(30)  -  BETAR         ANGLE FROM GA TO GB
C     ECPT(31)  -  MCSIDA        COORD. SYS. ID. FOR GRID POINT A
C     ECPT(32)  -  GPA(3)        *  BASIC COORD. FOR GRID POINT A
C     ECPT(33)  -   ...          *
C     ECPT(34)  -   ...          *
C     ECPT(35)  -  MCSIDB        COORD. SYS. ID. FOR GRID POINT B
C     ECPT(36)  -  GPB(3)        *  BASIC COORD. FOR GRID POINT B
C     ECPT(37)  -   ...          *
C     ECPT(38)  -   ...          *
C     ECPT(39)  -  ELTEMP        AVG. ELEMENT TEMPERATURE
C
C     COMMENTS FROM G.CHAN/UNISYS   7/91
C     ABOUT K1 AND K2, THE AREA FACTORS FOR SHEAR
C
C     THE K1,K2 FOR BAR ARE 0. TO 1.0, AND ARE USED IN K1*G*A AND K2*G*A
C         THE K1,K2 ARE THEREFORE CORRECTION FACTORS FOR STIFFNESS
C     THE K1,K2 ARE USED IN ELBOW IN K1/G*A AND K2/G*A. AND THEREFORE
C         THE K1,K2 ARE COORECTION FACTORS FOR FLEXIBILITY. THE K1,K2
C         IN ELBOW ARE EQUIVALENT TO 1./K1 AND 1./K2 IN BAR ELEMENT.
C         THE PROPER VALUE FOR K1 AND K2 SHOULD BE INFINITY TO 1.0
C
C     IN 1992 COSMIC/NASTRAN, THE USE OF K1 AND K2 IN ELBOW AND BAR
C     ELMENTS ARE SYMCHRONIZED, WITH PROPER VALUES FROM 0. TO 1.0
C     THE K1 AND K2 ARE CHANGED TO 1./K1 AND 1./K2 IN ELBOW ELEMENT
C     SHEAR COMPUTATION. THAT IS, CORRECTION FACTORS FOR STIFFNESS IS
C     USED.
C
C     REFERENCE -  R.J. ROARK: FORMULAS FOR STRESS AND STRAIN,
C     SECTION 35, 'BEAMS FOR RELATIVELY GREAT DEPTH',
C     FOR BEAMS OF SAMLL SPAN/DEPTH RATIO
C
C     K = 1/F = 5/6 FOR RECTANGULAR SECTION
C             = 0.9 FOR SOLID CIRCULAR
C             = 0.5 FOR THIN-WALLED HOOLOW CIRCULAR SECTION
C             = 1.0 CAN BE USED FOR I-BEAM
C
C
C
      LOGICAL          HEAT,ABASIC,BBASIC,BASIC
      REAL             K1,K2,I1,I2,NSM,KX,KY,KZ
      DOUBLE PRECISION TA(18),TB(9),SMALV0(6),DELA,DELB,KE,KEP,VECI,
     1                 VECJ,VECK,FL,FLL,DF(6,6),DETERM,H(6,6),DP(16),
     2                 S(12,12),DAMPC,KEE(12,12)
      DIMENSION        VECI(3),VECJ(3),VECK(3),ECPT(100),IECPT(100),
     1                 IZ(1),IWORK(6,3),F(6,6)
      COMMON /SMA1IO/  IFCSTM,IFMPT,IFDIT,IDUM1,IFECPT,IGECPT,IFGPCT,
     1                 IGGPCT,IFGEI,IGGEI,IFKGG,IGKGG,IF4GG,IG4GG,
     2                 IFGPST,IGGPST,INRW,OUTRW,CLSNRW,CLSRW,NEOR,
     3                 EOR,MCBKGG(7),MCB4GG(7)
      COMMON /ZZZZZZ/  Z(1)
      COMMON /SMA1BK/  ICSTM,NCSTM,IGPCT,NGPCT,IPOINT,NPOINT,I6X6K,
     1                 N6X6K,I6X64,N6X64
      COMMON /SMA1CL/  IOPT4,K4GGSW,NPVT,LEFT,FROWIC,LROWIC,NROWSC,
     1                 TNROWS,JMAX,NLINKS,LINK(10),IDETCK,DODET,NOGO
      COMMON /SMA1HT/  HEAT
      COMMON /SMA1ET/  IELID,ISILNO(2),SMALLV(3),ICSSV,IMATID,A,I1,I2,
     1                 FJ,NSM,FE,C1,C2,D1,D2,F1,F2,G1,G2,K1,K2,C,KX,KY,
     2                 KZ,R,BETAR,MCSIDA,GPA(3),MCSIDB,GPB(3),TEMPEL
      COMMON /SMA1DP/  KE(144),KEP(144),DELA(6),DELB(6)
      COMMON /MATIN /  MATIDC,MATFLG,ELTEMP,STRESS,SINTH,COSTH
      COMMON /MATOUT/  E,G,NU,RHO,ALPHA,TSUBO,GSUBE,SIGT,SIGC,SIGS
      COMMON /HMTOUT/  FK
      COMMON /SYSTEM/  SYSBUF,NOUT
      EQUIVALENCE      (IELID,ECPT(1),IECPT(1)),(IZ(1),Z(1)),
     1                 (TA(10),TB(1)),(ECPT(71),DP(1)),
     2                 (KEE(1,1),KE(1),S(1,1))
      DATA    DCR   /  .017453292 /
C
      SID(X) = SIN(X*DCR)
      COD(X) = COS(X*DCR)
      DTR(X) = X*DCR
C
C     DETERMINE WHICH POINT IS THE PIVOT POINT.
C
      X    = 1.
      IPVT = 1
      IF (ISILNO(1) .EQ. NPVT) GO TO 20
      IPVT = 2
      IF (ISILNO(2) .NE. NPVT) CALL MESAGE (-30,34,IECPT(1))
C
C     SET UP POINTERS TO COORD. SYSTEM IDS
C
   20 JCSIDA = 31
      JCSIDB = 35
      ICSIDA = IECPT(31)
      ICSIDB = IECPT(35)
C
C     DEFINE LOCATION OF END A, END B IN TERMS OF DP(1) THRU DP(6)
C
      DP(1) = ECPT(JCSIDA+1)
      DP(2) = ECPT(JCSIDA+2)
      DP(3) = ECPT(JCSIDA+3)
      DP(4) = ECPT(JCSIDB+1)
      DP(5) = ECPT(JCSIDB+2)
      DP(6) = ECPT(JCSIDB+3)
C
C     DEFINE COMPONENTS OF VECTOR FROM END A TO CENTER OF CURVATURE,C
C
      DP(7) = ECPT(4)
      DP(8) = ECPT(5)
      DP(9) = ECPT(6)
      FLD   = DSQRT(DP(7)**2 + DP(8)**2 + DP(9)**2)
      IF (FLD .LE. 0.000) GO TO 1010
      DP(7) = DP(7)/FLD
      DP(8) = DP(8)/FLD
      DP(9) = DP(9)/FLD
C
C     DETERMINE IF POINT A AND B ARE IN BASIC COORDINATES
C
      ABASIC =.TRUE.
      BBASIC =.TRUE.
      IF (ICSIDA .NE. 0) ABASIC =.FALSE.
      IF (ICSIDB .NE. 0) BBASIC =.FALSE.
C
C     COMPUTE THE TRANSFORMATION MATRICES TA AND TB IF NECESSARY
C
      IF (ABASIC) GO TO 30
      CALL TRANSD (ECPT(JCSIDA),TA)
      CALL GMMATD (TA,3,3,0, DP(7),3,1,0, VECJ)
      CALL GMMATD (TA,3,3,0, DP(1),3,1,0, DP(14))
      DP(1) = DP(14)
      DP(2) = DP(15)
      DP(3) = DP(16)
      GO TO 35
   30 CONTINUE
      VECJ(1) = DP(7)
      VECJ(2) = DP(8)
      VECJ(3) = DP(9)
   35 IF (BBASIC) GO TO 40
      CALL TRANSD (ECPT(JCSIDB),TB)
      CALL GMMATD (TB,3,3,0, DP(4),3,1,0, DP(14))
      DP(4) = DP(14)
      DP(5) = DP(15)
      DP(6) = DP(16)
   40 CONTINUE
C
C     CALCULATE TRUE LENGTH OF ELBOW
C
      FL = DBLE(R*DTR(BETAR))
      IF (FL .EQ. 0.0D0) GO TO 1010
C
C     NOW THAT LENGTH HAS BEEN COMPUTED, BRANCH IF THIS IS A -HEAT-
C     FORMULATION.
C
      IF (HEAT) GO TO 2000
C
C     CONSTRUCT VECTOR FROM A TO B
C
      SMALV0(1) = DP(4) - DP(1)
      SMALV0(2) = DP(5) - DP(2)
      SMALV0(3) = DP(6) - DP(3)
      FLL = DSQRT(SMALV0(1)**2 + SMALV0(2)**2 + SMALV0(3)**2)
      IF (FLL .EQ. 0.0D0) GO TO 1010
      SMALV0(1) = SMALV0(1)/FLL
      SMALV0(2) = SMALV0(2)/FLL
      SMALV0(3) = SMALV0(3)/FLL
C
C     COMPUTE THE K VECTOR VECK = SMALV0 X VECJ
C
      VECK(1) = SMALV0(2)*VECJ(3) - SMALV0(3)*VECJ(2)
      VECK(2) = SMALV0(3)*VECJ(1) - SMALV0(1)*VECJ(3)
      VECK(3) = SMALV0(1)*VECJ(2) - SMALV0(2)*VECJ(1)
      FLL = DSQRT(VECK(1)**2 + VECK(2)**2 + VECK(3)**2)
      IF (FLL .EQ. 0.0D0) GOTO 1010
      VECK(1) = VECK(1)/FLL
      VECK(2) = VECK(2)/FLL
      VECK(3) = VECK(3)/FLL
C
C     COMPUTE THE I VECTOR  VECI = VECJ X VECK
C
      VECI(1) = VECJ(2)*VECK(3) - VECJ(3)*VECK(2)
      VECI(2) = VECJ(3)*VECK(1) - VECJ(1)*VECK(3)
      VECI(3) = VECJ(1)*VECK(2) - VECJ(2)*VECK(1)
      FLL = DSQRT(VECI(1)**2 + VECI(2)**2 + VECI(3)**2)
      IF (FLL .EQ. 0.0D0) GO TO 1010
      VECI(1) = VECI(1)/FLL
      VECI(2) = VECI(2)/FLL
      VECI(3) = VECI(3)/FLL
C
C     SEARCH THE MATERIAL PROPERTIES TABLE FOR E,G AND THE DAMPING
C     CONSTANT.
C
      MATIDC = IMATID
      MATFLG = 1
      ELTEMP = TEMPEL
      CALL MAT (IECPT(1))
      DAMPC = G SUB E
C
C     SET UP INTERMEDIATE VARIABLES FOR ELEMENT STIFFNESS MATRIX
C     CALCULATION
C
      IF (KX .LT. 1.0E-8) KX = 1.0
      IF (KY .LT. 1.0E-8) KY = 1.0
      IF (KZ .LT. 1.0E-8) KZ = 1.0
      FI1 = I1/KZ
      FI2 = I2/KY
      FJK = FJ/KX
C
C     AREA FACTORS FOR SHEAR ARE FROM NEAR ZERO TO ONE
C
      IF (K1 .LT. 1.0E-8) K1 = 1.0
      IF (K2 .LT. 1.0E-8) K2 = 1.0
      IF (K1 .GT. 1.0) K1 = 1.0/K1
      IF (K2 .GT. 1.0) K2 = 1.0/K2
C
C     THE FOLLOWING CODE WAS TAKEN FROM SAP4 BENDKS ROUTINE
C     FOR A CURVED PIPE ELEMENT
C
C     COMPUTE SECTION PROPERTY CONSTANTS
C
      T   = DTR(BETAR)
      RA  = R/(A*E)
      RV1 = R/(2.*K1*G*A)
      RV2 = K1/K2*RV1
      RT  = R/(G*FJK*2.)
      RB0 = R/(E*FI2*2.)
      RB1 = R/(E*FI1)
      R2  = R**2
C
C     COMPUTE COMMON TRIGONOMETRIC CONSTANTS
C
      ST  = SID(BETAR)
      CT  = COD(BETAR)
      S2T = SID(2.0*BETAR)
      C2T = COD(2.0*BETAR)
C
C     FORM THE NODE FLEXIBILITY MATRIX AT NODE J REFERENCED TO THE
C     LOCAL (X,Y,Z) COORDINATE SYSTEM AT NODE I.
C
C     X - DIRECTION...  IN-PLANE TANGENT TO THE BEND AT NODE I AND
C                       DIRECTED TOWARD NODE J
C     Y - DIRECTION...  IN-PLANE AND DIRECTED RADIALLY INWARD TO THE
C                       CENTER OF CURVATURE
C     Z - DIRECTION...  OUT OF PLANE AND ORTHOGONAL TO X AND Y
C
      DO 50 I = 1,6
      DO 50 K = I,6
      F(I,K)  = 0.0
   50 CONTINUE
C
C     A X I A L
C
      F(1,1) = F(1,1) + 0.25*RA*(2.0*T+S2T)
      F(2,2) = F(2,2) + 0.25*RA*(2.0*T-S2T)
C
C     N O T E   (COEFFICIENT CHANGE)
C
      F(1,2) = F(1,2) + 0.50*RA*ST**2
C
C     S H E A R
C
      F(1,1) = F(1,1) + 0.5*RV1*(2.0*T-S2T)
      F(2,2) = F(2,2) + 0.5*RV1*(2.0*T+S2T)
      F(3,3) = F(3,3) + 2.0*RV2* T
C
C     N O T E   (SIGN CHANGE)
C
      F(1,2) = F(1,2) - RV1*ST**2
C
C     T O R S I O N
C
      F(3,3) = F(3,3) + 0.5*RT*R2*(6.0*T+S2T-8.0*ST)
      F(4,4) = F(4,4) + 0.5*RT*   (2.0*T+S2T)
      F(5,5) = F(5,5) + 0.5*RT*   (2.0*T-S2T)
      F(3,4) = F(3,4) +     RT*R *(ST-T*CT)
      F(3,5) = F(3,5) +     RT*R *(2.0-2.0*CT-T*ST)
      F(4,5) = F(4,5) + 0.5*RT*   (1.0-C2T)
C
C     B E N D I N G
C
      F(1,1) = F(1,1) + 0.25*RB1*R2*(2.0*T*(2.0+C2T)-3.0*S2T)
      F(2,2) = F(2,2) + 0.25*RB1*R2*(2.0*T*(2.0-C2T)+3.0*S2T-8.0*ST)
      F(3,3) = F(3,3) + 0.50*RB0*R2*(2.0*T-S2T)
      F(4,4) = F(4,4) + 0.50*RB0*   (2.0*T-S2T)
      F(5,5) = F(5,5) + 0.50*RB0*   (2.0*T+S2T)
      F(6,6) = F(6,6) +      RB1*T
      F(1,2) = F(1,2) + 0.25*RB1*R2*(1.0+3.0*C2T+2.0*T*S2T-4.0*CT)
      F(1,6) = F(1,6) -      RB1*R *(ST-T*CT)
      F(2,6) = F(2,6) +      RB1*R *(T*ST+CT-1.0)
      F(3,4) = F(3,4) +      RB0*R *(ST-T*CT)
      F(3,5) = F(3,5) -      RB0*R *T*ST
      F(4,5) = F(4,5) - 0.50*RB0*   (1.0-C2T)
C
C
C     FORM SYMMETRICAL UPPER PART OF FLEX MATRIX
C
      DO 65 I = 1,6
      DO 65 K = I,6
      DF(K,I) = DBLE(F(I,K))
      DF(I,K) = DF(K,I)
   65 CONTINUE
C
C     WRITE (6,4005) DF
C
C     INVERT FLEX TO FORM STIFFNESS
C
      CALL INVERD (6,DF,6,DUM,0,DETERM,ISING,IWORK)
      IF (ISING .EQ. 2) WRITE (6,4002) F
      IF (ISING .EQ. 2) CALL MESAGE (-30,38,ECPT(1))
 4002 FORMAT (1X,34HELBOW STIFFNESS MATRIX IS SINGULAR, /,(5X,6E13.5))
C
C
C     SET UP THE FORCE TRANSFORMATION RELATING REACTIONS AT NODE I
C     ACTING ON THE MEMBER END DUE TO UNIT LOADS APPLIED TO THE MEMBER
C     END AT NODE J.
C
      DO 100 I = 1,6
      DO 100 K = 1,6
      H(I,K) = 0.0D0
  100 CONTINUE
C
      DO 105 K = 1,6
      H(K,K) =-1.0D0
  105 CONTINUE
C
      H(4,3) =-DBLE(R*(1.0-CT))
      H(5,3) = DBLE(R*ST)
      H(6,1) =-H(4,3)
      H(6,2) =-H(5,3)
C
C     FORM THE UPPER TRIANGULAR PORTION OF THE LOCAL ELEMENT STIFFNESS
C     MATRIX FOR THE BEND
C
      DO 110 K = 1,6
      DO 110 I = K,6
      S(K+6,I+6) = DF(K,I)
  110 CONTINUE
C
      DO 130 IR = 1,6
      DO 130 IC = 1,6
      S(IR,IC+6) = 0.0D0
      DO 120 IN = 1,6
      S(IR,IC+6) = S(IR,IC+6) + H(IR,IN)*DF(IN,IC)
  120 CONTINUE
  130 CONTINUE
C
      DO 150 IR = 1,6
      DO 150 IC = IR,6
      S(IR,IC)  = 0.0D0
      DO 140 IN = 1,6
      S(IR,IC) = S(IR,IC) + S(IR,IN+6)*H(IC,IN)
  140 CONTINUE
  150 CONTINUE
C
C     REFLECT FOR SYMMETRY
C
      DO 165 I = 1,12
      DO 165 K = I,12
      S(K,I)   = S(I,K)
  165 CONTINUE
C
      J = 0
      IF (IPVT .EQ. 2) GO TO 327
      ILOW = 1
      ILIM = 72
      GO TO 329
  327 ILOW = 73
      ILIM = 144
  329 DO 340 I = ILOW,ILIM,12
      LOW = I
      LIM = LOW + 5
      DO 330 K = LOW,LIM
      J = J + 1
      KEP(J) = KE(K)
  330 KEP(J+36) = KE(K+6)
  340 CONTINUE
C
C                                                            T
C     STORE VECI, VECJ, VECK IN KE(1),...,KE(9) FORMING THE A  MATRIX.
C
      KE(1) = VECI(1)
      KE(2) = VECI(2)
      KE(3) = VECI(3)
      KE(4) = VECJ(1)
      KE(5) = VECJ(2)
      KE(6) = VECJ(3)
      KE(7) = VECK(1)
      KE(8) = VECK(2)
      KE(9) = VECK(3)
C
C     ZERO OUT THE ARRAY WHERE THE 3 X 3 MATRIX H AND THE W  AND W
C     6 X 6  MATRICES WILL RESIDE.                         A      B
C
      DO 350 I = 28,108
  350 KE(I) = 0.0D0
      IPASS = 1
      IWBEG = 0
C
C     SET UP POINTERS
C
      IF (IPVT-1) 365,360,365
  360 BASIC  = ABASIC
      JCSID  = JCSIDA
      IKEL   = 1
      INDEX  = ISILNO(1)
      GO TO 368
  365 BASIC  = BBASIC
      JCSID  = JCSIDB
      IKEL   = 37
      INDEX  = ISILNO(2)
C
C     SET UP THE -G- MATRIX.  IG POINTS TO THE BEGINNING OF THE G
C     MATRIX. G = AT X TI
C
  368 IG = 1
      IF (BASIC) GO TO 380
      CALL TRANSD (ECPT(JCSID),KE(10))
      CALL GMMATD (KE(1),3,3,0, KE(10),3,3,0, KE(19))
      IG = 19
C
C     FORM THE W  MATRIX OR THE W  MATRIX IN KE(37) OR KE(73) DEPENDING
C               A                B
C     UPON WHICH POINT - A OR B - IS UNDER CONSIDERATION.  G WILL BE
C     STORED IN THE UPPER LEFT AND LOWER RIGHT CORNERS.  H, IF NON-ZERO,
C     WILL BE STORED IN THE UPPER RIGHT CORNER.
C
  380 KE(IWBEG+37) = KE(IG  )
      KE(IWBEG+38) = KE(IG+1)
      KE(IWBEG+39) = KE(IG+2)
      KE(IWBEG+43) = KE(IG+3)
      KE(IWBEG+44) = KE(IG+4)
      KE(IWBEG+45) = KE(IG+5)
      KE(IWBEG+49) = KE(IG+6)
      KE(IWBEG+50) = KE(IG+7)
      KE(IWBEG+51) = KE(IG+8)
      KE(IWBEG+58) = KE(IG  )
      KE(IWBEG+59) = KE(IG+1)
      KE(IWBEG+60) = KE(IG+2)
      KE(IWBEG+64) = KE(IG+3)
      KE(IWBEG+65) = KE(IG+4)
      KE(IWBEG+66) = KE(IG+5)
      KE(IWBEG+70) = KE(IG+6)
      KE(IWBEG+71) = KE(IG+7)
      KE(IWBEG+72) = KE(IG+8)
C
C                       T      E
C     FORM THE PRODUCT W   X  K   AND STORE IN KEP(73)
C                       NPVT
C
      CALL GMMATD (KE(37),6,6,1, KEP(IKEL),6,6,0, KEP(73))
C
C     COMPUTE THE FINAL ANSWER AND STORE IN KEP(109)
C
      CALL GMMATD (KEP(73),6,6,0, KE(IWBEG+37),6,6,0, KEP(109))
C
C     INSERT THIS 6 X 6
C
      CALL SMA1B (KEP(109),INDEX,-1,IFKGG,0.0D0)
      IF (IOPT4.EQ.0 .OR. GSUBE.EQ.0.0) GO TO 400
      K4GGSW = 1
      CALL SMA1B (KEP(109),INDEX,-1,IF4GG,DAMPC)
C
C     IF IPASS = 2, WE ARE DONE.  OTHERWISE COMPUTE THE OFF-DIAGONAL
C     6 X 6.
C
  400 IF (IPASS .EQ. 2) GO TO 500
      IWBEG = 36
      IPASS = 2
      DO 410 I = 28,36
  410 KE(I) = 0.0D0
      IF (IPVT-1) 360,365,360
  500 RETURN
C
 1010 CALL MESAGE (30,26,IECPT(1))
C
C     SET FLAG FOR FATAL ERROR WHILE ALLOWING ERROR MESSAGES TO
C     ACCUMULATE
C
      NOGO = 1
      RETURN
C
C
C     HEAT FORMULATION CONTINUES HERE.  GET MATERIAL PROPERTY -K- FROM
C     HMAT
C
 2000 MATFLG = 1
      MATIDC = IECPT( 8)
      ELTEMP = ECPT(39)
      CALL HMAT (IELID)
C
      FL = DBLE(FK)*DBLE(ECPT(9))/(DP(9)*DP(10)*DBLE(DCR))
      IF (NPVT .EQ. IECPT(3)) FL = -FL
      DO 2020 I = 1,2
      CALL SMA1B (FL,IECPT(I+1),NPVT,IFKGG,0.0D0)
      FL = -FL
 2020 CONTINUE
      RETURN
      END


!**********************************************************************************************************************************
!
!  Name        : extreme
!  Language    : Fortran 90
!
!  Description : 極値を求める
!
!
!  Input
!    Arguments : none
!    Terminal  : none
!    File      : out.dat
!
!  Output
!    Arguments : none
!    Terminal  : none
!    File      : extreme.txt
!
!  Invocation  : none
!
!  Notes       : none
!**********************************************************************************************************************************

PROGRAM extreme
  IMPLICIT NONE
  DOUBLEPRECISION,DIMENSION(4000,2) :: S = 0D0
  INTEGER :: i

open (10, file="out.dat",status="old")
do i=1,4000
  read(10,*) S(i,1), S(i,2)
end do
close(10)

open(11, file="extreme.txt",status="unknown",position="append")
do i=1,3998
  if (S(i+1,2)>S(i,2)) then
    if (S(i+1,2)>S(i+2,2)) then
      write(11,*) S(i+1,1),S(i+1,2),"lmax"
    end if
  else if (S(i+1,2)<S(i,2)) then
    if (S(i+1,2)<S(i+2,2)) then
      write(11,*) S(i+1,1),S(i+1,2),"lmin"
    end if
  end if
end do
close(11)

END PROGRAM


submodule (stdlib_stats) stdlib_stats_moment

  use, intrinsic:: ieee_arithmetic, only: ieee_value, ieee_quiet_nan
  use stdlib_error, only: error_stop
  use stdlib_optval, only: optval
  implicit none

contains

      module function moment_1_rdp_rdp(x, order, dim, center, mask) result(res)
        real(dp), intent(in) :: x(:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        real(dp), intent(in), optional :: center
        logical, intent(in), optional :: mask
        real(dp) :: res

        integer :: i
        real(dp) :: n
        real(dp), allocatable :: mean_

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = real(size(x, dim), dp)

        res = 0
        select case(dim)
          case(1)
            if (present(center)) then
              do i = 1, size(x, 1)
                res = res + (x(i) - center)**order
              end do
            else
              allocate(mean_, source = mean(x, 1))
              do i = 1, size(x, 1)
                res = res + (x(i) - mean_)**order
              end do
              deallocate(mean_)
            end if
          case default
            call error_stop("ERROR (moment): wrong dimension")
        end select
        res = res / n

      end function moment_1_rdp_rdp
      module function moment_2_rdp_rdp(x, order, dim, center, mask) result(res)
        real(dp), intent(in) :: x(:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        real(dp), intent(in), optional :: center(merge(size(x, 1), size(x, 2), mask=1<dim))
        logical, intent(in), optional :: mask
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim))

        integer :: i
        real(dp) :: n
        real(dp), allocatable :: mean_(:)

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = real(size(x, dim), dp)

        res = 0
        select case(dim)
          case(1)
            if (present(center)) then
              do i = 1, size(x, 1)
                res = res + (x(i, :) - center)**order
              end do
            else
              allocate(mean_, source = mean(x, 1))
              do i = 1, size(x, 1)
                res = res + (x(i, :) - mean_)**order
              end do
              deallocate(mean_)
            end if
          case(2)
            if (present(center)) then
              do i = 1, size(x, 2)
                res = res + (x(:, i) - center)**order
              end do
            else
              allocate(mean_, source = mean(x, 2))
              do i = 1, size(x, 2)
                res = res + (x(:, i) - mean_)**order
              end do
              deallocate(mean_)
            end if
          case default
            call error_stop("ERROR (moment): wrong dimension")
        end select
        res = res / n

      end function moment_2_rdp_rdp
      module function moment_3_rdp_rdp(x, order, dim, center, mask) result(res)
        real(dp), intent(in) :: x(:,:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        real(dp), intent(in), optional :: center(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3),&
            & mask=2<dim))
        logical, intent(in), optional :: mask
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim))

        integer :: i
        real(dp) :: n
        real(dp), allocatable :: mean_(:,:)

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = real(size(x, dim), dp)

        res = 0
        select case(dim)
          case(1)
            if (present(center)) then
              do i = 1, size(x, 1)
                res = res + (x(i, :, :) - center)**order
              end do
            else
              allocate(mean_, source = mean(x, 1))
              do i = 1, size(x, 1)
                res = res + (x(i, :, :) - mean_)**order
              end do
              deallocate(mean_)
            end if
          case(2)
            if (present(center)) then
              do i = 1, size(x, 2)
                res = res + (x(:, i, :) - center)**order
              end do
            else
              allocate(mean_, source = mean(x, 2))
              do i = 1, size(x, 2)
                res = res + (x(:, i, :) - mean_)**order
              end do
              deallocate(mean_)
            end if
          case(3)
            if (present(center)) then
              do i = 1, size(x, 3)
                res = res + (x(:, :, i) - center)**order
              end do
            else
              allocate(mean_, source = mean(x, 3))
              do i = 1, size(x, 3)
                res = res + (x(:, :, i) - mean_)**order
              end do
              deallocate(mean_)
            end if
          case default
            call error_stop("ERROR (moment): wrong dimension")
        end select
        res = res / n

      end function moment_3_rdp_rdp
      module function moment_4_rdp_rdp(x, order, dim, center, mask) result(res)
        real(dp), intent(in) :: x(:,:,:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        real(dp), intent(in), optional :: center(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3),&
            & mask=2<dim), merge(size(x, 3), size(x, 4), mask=3<dim))
        logical, intent(in), optional :: mask
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim), merge(size(x, 3),&
            & size(x, 4), mask=3<dim))

        integer :: i
        real(dp) :: n
        real(dp), allocatable :: mean_(:,:,:)

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = real(size(x, dim), dp)

        res = 0
        select case(dim)
          case(1)
            if (present(center)) then
              do i = 1, size(x, 1)
                res = res + (x(i, :, :, :) - center)**order
              end do
            else
              allocate(mean_, source = mean(x, 1))
              do i = 1, size(x, 1)
                res = res + (x(i, :, :, :) - mean_)**order
              end do
              deallocate(mean_)
            end if
          case(2)
            if (present(center)) then
              do i = 1, size(x, 2)
                res = res + (x(:, i, :, :) - center)**order
              end do
            else
              allocate(mean_, source = mean(x, 2))
              do i = 1, size(x, 2)
                res = res + (x(:, i, :, :) - mean_)**order
              end do
              deallocate(mean_)
            end if
          case(3)
            if (present(center)) then
              do i = 1, size(x, 3)
                res = res + (x(:, :, i, :) - center)**order
              end do
            else
              allocate(mean_, source = mean(x, 3))
              do i = 1, size(x, 3)
                res = res + (x(:, :, i, :) - mean_)**order
              end do
              deallocate(mean_)
            end if
          case(4)
            if (present(center)) then
              do i = 1, size(x, 4)
                res = res + (x(:, :, :, i) - center)**order
              end do
            else
              allocate(mean_, source = mean(x, 4))
              do i = 1, size(x, 4)
                res = res + (x(:, :, :, i) - mean_)**order
              end do
              deallocate(mean_)
            end if
          case default
            call error_stop("ERROR (moment): wrong dimension")
        end select
        res = res / n

      end function moment_4_rdp_rdp
      module function moment_1_cdp_cdp(x, order, dim, center, mask) result(res)
        complex(dp), intent(in) :: x(:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        complex(dp), intent(in), optional :: center
        logical, intent(in), optional :: mask
        complex(dp) :: res

        integer :: i
        real(dp) :: n
        complex(dp), allocatable :: mean_

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = real(size(x, dim), dp)

        res = 0
        select case(dim)
          case(1)
            if (present(center)) then
              do i = 1, size(x, 1)
                res = res + (x(i) - center)**order
              end do
            else
              allocate(mean_, source = mean(x, 1))
              do i = 1, size(x, 1)
                res = res + (x(i) - mean_)**order
              end do
              deallocate(mean_)
            end if
          case default
            call error_stop("ERROR (moment): wrong dimension")
        end select
        res = res / n

      end function moment_1_cdp_cdp
      module function moment_2_cdp_cdp(x, order, dim, center, mask) result(res)
        complex(dp), intent(in) :: x(:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        complex(dp), intent(in), optional :: center(merge(size(x, 1), size(x, 2), mask=1<dim))
        logical, intent(in), optional :: mask
        complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim))

        integer :: i
        real(dp) :: n
        complex(dp), allocatable :: mean_(:)

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = real(size(x, dim), dp)

        res = 0
        select case(dim)
          case(1)
            if (present(center)) then
              do i = 1, size(x, 1)
                res = res + (x(i, :) - center)**order
              end do
            else
              allocate(mean_, source = mean(x, 1))
              do i = 1, size(x, 1)
                res = res + (x(i, :) - mean_)**order
              end do
              deallocate(mean_)
            end if
          case(2)
            if (present(center)) then
              do i = 1, size(x, 2)
                res = res + (x(:, i) - center)**order
              end do
            else
              allocate(mean_, source = mean(x, 2))
              do i = 1, size(x, 2)
                res = res + (x(:, i) - mean_)**order
              end do
              deallocate(mean_)
            end if
          case default
            call error_stop("ERROR (moment): wrong dimension")
        end select
        res = res / n

      end function moment_2_cdp_cdp
      module function moment_3_cdp_cdp(x, order, dim, center, mask) result(res)
        complex(dp), intent(in) :: x(:,:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        complex(dp), intent(in), optional :: center(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3),&
            & mask=2<dim))
        logical, intent(in), optional :: mask
        complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim))

        integer :: i
        real(dp) :: n
        complex(dp), allocatable :: mean_(:,:)

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = real(size(x, dim), dp)

        res = 0
        select case(dim)
          case(1)
            if (present(center)) then
              do i = 1, size(x, 1)
                res = res + (x(i, :, :) - center)**order
              end do
            else
              allocate(mean_, source = mean(x, 1))
              do i = 1, size(x, 1)
                res = res + (x(i, :, :) - mean_)**order
              end do
              deallocate(mean_)
            end if
          case(2)
            if (present(center)) then
              do i = 1, size(x, 2)
                res = res + (x(:, i, :) - center)**order
              end do
            else
              allocate(mean_, source = mean(x, 2))
              do i = 1, size(x, 2)
                res = res + (x(:, i, :) - mean_)**order
              end do
              deallocate(mean_)
            end if
          case(3)
            if (present(center)) then
              do i = 1, size(x, 3)
                res = res + (x(:, :, i) - center)**order
              end do
            else
              allocate(mean_, source = mean(x, 3))
              do i = 1, size(x, 3)
                res = res + (x(:, :, i) - mean_)**order
              end do
              deallocate(mean_)
            end if
          case default
            call error_stop("ERROR (moment): wrong dimension")
        end select
        res = res / n

      end function moment_3_cdp_cdp
      module function moment_4_cdp_cdp(x, order, dim, center, mask) result(res)
        complex(dp), intent(in) :: x(:,:,:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        complex(dp), intent(in), optional :: center(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3),&
            & mask=2<dim), merge(size(x, 3), size(x, 4), mask=3<dim))
        logical, intent(in), optional :: mask
        complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim), merge(size(x, 3),&
            & size(x, 4), mask=3<dim))

        integer :: i
        real(dp) :: n
        complex(dp), allocatable :: mean_(:,:,:)

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = real(size(x, dim), dp)

        res = 0
        select case(dim)
          case(1)
            if (present(center)) then
              do i = 1, size(x, 1)
                res = res + (x(i, :, :, :) - center)**order
              end do
            else
              allocate(mean_, source = mean(x, 1))
              do i = 1, size(x, 1)
                res = res + (x(i, :, :, :) - mean_)**order
              end do
              deallocate(mean_)
            end if
          case(2)
            if (present(center)) then
              do i = 1, size(x, 2)
                res = res + (x(:, i, :, :) - center)**order
              end do
            else
              allocate(mean_, source = mean(x, 2))
              do i = 1, size(x, 2)
                res = res + (x(:, i, :, :) - mean_)**order
              end do
              deallocate(mean_)
            end if
          case(3)
            if (present(center)) then
              do i = 1, size(x, 3)
                res = res + (x(:, :, i, :) - center)**order
              end do
            else
              allocate(mean_, source = mean(x, 3))
              do i = 1, size(x, 3)
                res = res + (x(:, :, i, :) - mean_)**order
              end do
              deallocate(mean_)
            end if
          case(4)
            if (present(center)) then
              do i = 1, size(x, 4)
                res = res + (x(:, :, :, i) - center)**order
              end do
            else
              allocate(mean_, source = mean(x, 4))
              do i = 1, size(x, 4)
                res = res + (x(:, :, :, i) - mean_)**order
              end do
              deallocate(mean_)
            end if
          case default
            call error_stop("ERROR (moment): wrong dimension")
        end select
        res = res / n

      end function moment_4_cdp_cdp

      module function moment_1_iint32_dp(x, order, dim, center, mask) result(res)
        integer(int32), intent(in) :: x(:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        real(dp),intent(in), optional :: center
        logical, intent(in), optional :: mask
        real(dp) :: res

        integer :: i
        real(dp) :: n
        real(dp), allocatable :: mean_

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = real(size(x, dim), dp)

        res = 0
        select case(dim)
          case(1)
            if (present(center)) then
              do i = 1, size(x, 1)
                res = res + (real(x(i), dp) -&
                  center)**order
              end do
            else
              allocate(mean_, source = mean(x, 1))
              do i = 1, size(x, 1)
                res = res + (real(x(i), dp) - mean_)**order
              end do
              deallocate(mean_)
            end if
          case default
            call error_stop("ERROR (moment): wrong dimension")
        end select
        res = res / n

      end function moment_1_iint32_dp
      module function moment_2_iint32_dp(x, order, dim, center, mask) result(res)
        integer(int32), intent(in) :: x(:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        real(dp),intent(in), optional :: center(merge(size(x, 1), size(x, 2), mask=1<dim))
        logical, intent(in), optional :: mask
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim))

        integer :: i
        real(dp) :: n
        real(dp), allocatable :: mean_(:)

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = real(size(x, dim), dp)

        res = 0
        select case(dim)
          case(1)
            if (present(center)) then
              do i = 1, size(x, 1)
                res = res + (real(x(i, :), dp) -&
                  center)**order
              end do
            else
              allocate(mean_, source = mean(x, 1))
              do i = 1, size(x, 1)
                res = res + (real(x(i, :), dp) - mean_)**order
              end do
              deallocate(mean_)
            end if
          case(2)
            if (present(center)) then
              do i = 1, size(x, 2)
                res = res + (real(x(:, i), dp) -&
                  center)**order
              end do
            else
              allocate(mean_, source = mean(x, 2))
              do i = 1, size(x, 2)
                res = res + (real(x(:, i), dp) - mean_)**order
              end do
              deallocate(mean_)
            end if
          case default
            call error_stop("ERROR (moment): wrong dimension")
        end select
        res = res / n

      end function moment_2_iint32_dp
      module function moment_3_iint32_dp(x, order, dim, center, mask) result(res)
        integer(int32), intent(in) :: x(:,:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        real(dp),intent(in), optional :: center(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3),&
            & mask=2<dim))
        logical, intent(in), optional :: mask
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim))

        integer :: i
        real(dp) :: n
        real(dp), allocatable :: mean_(:,:)

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = real(size(x, dim), dp)

        res = 0
        select case(dim)
          case(1)
            if (present(center)) then
              do i = 1, size(x, 1)
                res = res + (real(x(i, :, :), dp) -&
                  center)**order
              end do
            else
              allocate(mean_, source = mean(x, 1))
              do i = 1, size(x, 1)
                res = res + (real(x(i, :, :), dp) - mean_)**order
              end do
              deallocate(mean_)
            end if
          case(2)
            if (present(center)) then
              do i = 1, size(x, 2)
                res = res + (real(x(:, i, :), dp) -&
                  center)**order
              end do
            else
              allocate(mean_, source = mean(x, 2))
              do i = 1, size(x, 2)
                res = res + (real(x(:, i, :), dp) - mean_)**order
              end do
              deallocate(mean_)
            end if
          case(3)
            if (present(center)) then
              do i = 1, size(x, 3)
                res = res + (real(x(:, :, i), dp) -&
                  center)**order
              end do
            else
              allocate(mean_, source = mean(x, 3))
              do i = 1, size(x, 3)
                res = res + (real(x(:, :, i), dp) - mean_)**order
              end do
              deallocate(mean_)
            end if
          case default
            call error_stop("ERROR (moment): wrong dimension")
        end select
        res = res / n

      end function moment_3_iint32_dp
      module function moment_4_iint32_dp(x, order, dim, center, mask) result(res)
        integer(int32), intent(in) :: x(:,:,:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        real(dp),intent(in), optional :: center(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3),&
            & mask=2<dim), merge(size(x, 3), size(x, 4), mask=3<dim))
        logical, intent(in), optional :: mask
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim), merge(size(x, 3),&
            & size(x, 4), mask=3<dim))

        integer :: i
        real(dp) :: n
        real(dp), allocatable :: mean_(:,:,:)

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = real(size(x, dim), dp)

        res = 0
        select case(dim)
          case(1)
            if (present(center)) then
              do i = 1, size(x, 1)
                res = res + (real(x(i, :, :, :), dp) -&
                  center)**order
              end do
            else
              allocate(mean_, source = mean(x, 1))
              do i = 1, size(x, 1)
                res = res + (real(x(i, :, :, :), dp) - mean_)**order
              end do
              deallocate(mean_)
            end if
          case(2)
            if (present(center)) then
              do i = 1, size(x, 2)
                res = res + (real(x(:, i, :, :), dp) -&
                  center)**order
              end do
            else
              allocate(mean_, source = mean(x, 2))
              do i = 1, size(x, 2)
                res = res + (real(x(:, i, :, :), dp) - mean_)**order
              end do
              deallocate(mean_)
            end if
          case(3)
            if (present(center)) then
              do i = 1, size(x, 3)
                res = res + (real(x(:, :, i, :), dp) -&
                  center)**order
              end do
            else
              allocate(mean_, source = mean(x, 3))
              do i = 1, size(x, 3)
                res = res + (real(x(:, :, i, :), dp) - mean_)**order
              end do
              deallocate(mean_)
            end if
          case(4)
            if (present(center)) then
              do i = 1, size(x, 4)
                res = res + (real(x(:, :, :, i), dp) -&
                  center)**order
              end do
            else
              allocate(mean_, source = mean(x, 4))
              do i = 1, size(x, 4)
                res = res + (real(x(:, :, :, i), dp) - mean_)**order
              end do
              deallocate(mean_)
            end if
          case default
            call error_stop("ERROR (moment): wrong dimension")
        end select
        res = res / n

      end function moment_4_iint32_dp

end submodule


c               Copyright 1993 Colorado State University
c                       All Rights Reserved

      subroutine nfixday(ppt, atmosNdep, nonSymSoilNfix)

c ... Compute the amount of atmospheric and non-symbiotic soil N-fixation
c ... for the current day and add it to minerl(1,N)

      implicit none
      include 'const.inc'
      include 'npool.inc'
      include 'param.inc'
      include 'parfx.inc'
      include 'plot1.inc'
      include 'plot2.inc'
      include 'timvar.inc'
      include 'zztim.inc'

c ... Formal parameters
      double precision ppt, atmosNdep, nonSymSoilNfix

c ... Function declarations
      double precision fsfunc
      external  fsfunc

c ... FORMAL PARAMETERS
c ... Input
c ...   ppt		- precipitation for the current day (cm)
c ... Output
c ...   atmosNdep	- atmospheric N deposition (gN/m^2)
c ...   nonSymSoilNfix	- non-symbiotic soil N fixation (gN/m^2)

c ... N FIXATION VARIABLES (plot1.inc)
c ... "wdfx" stands for wet/dry fixation of N
c ...   wdfxa 	- average annual rate of atmospheric N deposition (gN/m^2)
c ...   wdfxs 	- average annual rate of non-symbiotic soil N fixation (gN/m^2)
c ...   wdfx = wdfxa + wdfxs
c ...   wdfxma 	- actual amount of atmospheric N deposition this month (gN/m^2)
c ...   wdfxms 	- actual amount of non-symbiotic soil N fixation this month (gN/m^2)
c ...   wdfxm = wdfxma + wdfxms
c ...   wdfxaa 	- accumulator for the actual amount of atmospheric N deposition this year (gN/m^2)
c ...   wdfxas 	- accumulator for the actual amount of non-symbiotic soil N fixation this year (gN/m^2)

c ... Local Variables
      integer clyr
      double precision frac_nh4, frac_no3
      double precision biof, fwdfx, fxbiom
      double precision wdfnp, wdfxm
      double precision tbiom
      double precision totNfix
      character subname*10

c ... N Fixation
c ... Does not take into account the effect of irrigation

      if (nsnfix .eq. 1 .and. nelem .ge. P) then

c.......Non symbiotic N fixation should be based on N:P ratio in mineral pool
c ..... Compute mineral N:P ratio for N-Fixation (use suface layer only)
c ..... rnpml1 is used to control soil N-fixation using a regression
c ..... equation based on Kansas data. This ratio is used only if nelem = 2.
c ..... rnpml1 is flagged if either minerl(1,1) or minerl(1,2) is zero.

        rnpml1 = minerl(1,N)/minerl(1,P)*
     &           fsfunc(minerl(1,P),pslsrb,sorpmx)

c ..... Wet-dry fixation of nitrogen -- monthly flow
c ..... Atmospheric fixation is split between monthly dry fall and
c ..... wdfnp is the N:P ratio control function for non-symbiotic
c ..... soil fixation.
c ..... Both wdfnp and fxbiom are relative functions
c ..... which vary from 0 to 1.
c ..... wdfnp computed as a negative natural log of rnpml1
c ..... symnfx is the symbiotic N fixation by legumes derived from Cole and
c ..... Heil (1981) using data from Walker et al. 1959.
        if (rnpml1 .eq. 0) then
          wdfnp = 1.
        else
          wdfnp = min(1., ((-alog(real(rnpml1)))/fxnpb)-.2)
        endif

c ..... The definitions of fxmca and fxmcb originally refered to water,
c ..... not biomass. (Alister 11/91)
        tbiom = aglivc + stdedc + strucc(SRFC)
        biof  = fxmca + tbiom * fxmcb
        fxbiom = 1 - biof
        fxbiom = min(1.,fxbiom)
        if (wdfnp .lt. 0 .or. fxbiom .lt. 0 .or. stemp .lt. 7.5) then
          fwdfx = 0.0
        else
          fwdfx = wdfnp * fxbiom
        endif

c ..... Compute N-fixation for the month

c ..... Wet fall depending on the monthly precipitation (wdfxma)
c ..... 30.42 is the average number of days in a month

        nonSymSoilNfix = fxmxs * fwdfx / 30.42
        atmosNdep = wdfxa * ppt / prcann
        totNfix = nonSymSoilNfix + atmosNdep
        wdfxms = wdfxms + nonSymSoilNfix
        wdfxma = wdfxma + atmosNdep
        wdfxm = wdfxma + wdfxms
        wdfxas = wdfxas + nonSymSoilNfix
        wdfxaa = wdfxaa + atmosNdep

c       wdfxms = fxmxs * fwdfx
c       wdfxma = wdfxa * precip(month) / prcann
c       wdfxas = wdfxas + wdfxms
c       wdfxaa = wdfxaa + wdfxma

c ..... Compute annual N-fixation accumulators for atmosphere and soils
        frac_nh4 = 0.5
        frac_no3 = 0.5

        clyr = 1
        subname = 'nfixation '
        call update_npool(clyr, totNfix, frac_nh4, frac_no3, ammonium,
     &                    nitrate, subname)
        call flow(esrsnk(N),minerl(1,N),time,totNfix)

c.....Non symbiotic N fixation is based on annual precipitation.
      else
        frac_nh4 = 0.5
        frac_no3 = 0.5
        nonSymSoilNfix = wdfxs * ppt / prcann
        atmosNdep = wdfxa * ppt / prcann
        totNfix = nonSymSoilNfix + atmosNdep
        wdfxms = wdfxms + nonSymSoilNfix
        wdfxma = wdfxma + atmosNdep
        wdfxm = wdfxma + wdfxms
        wdfxas = wdfxas + nonSymSoilNfix
        wdfxaa = wdfxaa + atmosNdep

c       wdfxms = wdfxs * precip(month) / prcann
c       wdfxma = wdfxa * precip(month) / prcann
c       wdfxas = wdfxas + wdfxms
c       wdfxaa = wdfxaa + wdfxma

        clyr = 1
        call update_npool(clyr, totNfix, frac_nh4, frac_no3, ammonium,
     &                    nitrate, subname)
        call flow(esrsnk(N),minerl(1,N),time,totNfix)
      endif

      return
      end


      INTEGER N_HK, N_RT, N_TREH
      REAL, DIMENSION(1,6) :: HK_RANGE
      REAL, DIMENSION(1,5) :: RT_RANGE
      REAL, DIMENSION(1,3) :: TREH_RANGE
      REAL, DIMENSION(6,5,3) :: CEC_TABLE

      N_HK   = 6
      N_RT   = 5
      N_TREH = 3

      HK_RANGE(1,1) = 7.0E0/5.0E0
      HK_RANGE(1,2) = 8.0E0/5.0E0
      HK_RANGE(1,3) = 9.0E0/5.0E0
      HK_RANGE(1,4) = 2.0E0
      HK_RANGE(1,5) = 1.1E1/5.0E0
      HK_RANGE(1,6) = 1.2E1/5.0E0

      RT_RANGE(1,1) = 8.0E2
      RT_RANGE(1,2) = 1.6E3
      RT_RANGE(1,3) = 3.2E3
      RT_RANGE(1,4) = 6.4E3
      RT_RANGE(1,5) = 1.28E4

      TREH_RANGE(1,2) = 5.0E1
      TREH_RANGE(1,3) = 1.0E2

      CEC_TABLE(1,1,2) = 2.872680733645279E-1
      CEC_TABLE(1,1,3) = 7.749716029388073E-1
      CEC_TABLE(1,2,2) = 2.039644535775086E-1
      CEC_TABLE(1,2,3) = 5.924318712770024E-1
      CEC_TABLE(1,3,2) = 1.443700895511554E-1
      CEC_TABLE(1,3,3) = 4.633605499494066E-1
      CEC_TABLE(1,4,2) = 1.004911816583118E-1
      CEC_TABLE(1,4,3) = 3.699178360235265E-1
      CEC_TABLE(1,5,2) = 6.733821510084832E-2
      CEC_TABLE(1,5,3) = 3.001150710959782E-1
      CEC_TABLE(2,1,2) = 2.15679590997346E-1
      CEC_TABLE(2,1,3) = 7.032901821333088E-1
      CEC_TABLE(2,2,2) = 1.38804898233508E-1
      CEC_TABLE(2,2,3) = 5.190092839824512E-1
      CEC_TABLE(2,3,2) = 8.540581665774229E-2
      CEC_TABLE(2,3,3) = 3.955784955811628E-1
      CEC_TABLE(2,4,2) = 4.687087515554092E-2
      CEC_TABLE(2,4,3) = 3.083346385006999E-1
      CEC_TABLE(2,5,2) = 1.823657536308939E-2
      CEC_TABLE(2,5,3) = 2.440957040061711E-1
      CEC_TABLE(3,1,2) = 1.351465804725244E-1
      CEC_TABLE(3,1,3) = 5.944539142560507E-1
      CEC_TABLE(3,2,2) = 6.948210676888233E-2
      CEC_TABLE(3,2,3) = 4.287398277454012E-1
      CEC_TABLE(3,3,2) = 2.446511411233687E-2
      CEC_TABLE(3,3,3) = 3.186820261578073E-1
      CEC_TABLE(3,4,3) = 2.413596674968999E-1
      CEC_TABLE(3,5,3) = 1.847296324018285E-1
      CEC_TABLE(4,1,2) = 5.497866179885413E-2
      CEC_TABLE(4,1,3) = 4.803653864888552E-1
      CEC_TABLE(4,2,2) = 1.021202577184958E-3
      CEC_TABLE(4,2,3) = 3.363622877434947E-1
      CEC_TABLE(4,3,3) = 2.409694933687837E-1
      CEC_TABLE(4,4,3) = 1.741794817845234E-1
      CEC_TABLE(4,5,3) = 1.254740804951762E-1
      CEC_TABLE(5,1,3) = 3.674090874850944E-1
      CEC_TABLE(5,2,3) = 2.450395028559258E-1
      CEC_TABLE(5,3,3) = 1.641449222712615E-1
      CEC_TABLE(5,4,3) = 1.077346391909527E-1
      CEC_TABLE(5,5,3) = 6.682986734578829E-2
      CEC_TABLE(6,1,3) = 2.566658710465144E-1
      CEC_TABLE(6,2,3) = 1.54999205732387E-1
      CEC_TABLE(6,3,3) = 8.805729195880023E-2
      CEC_TABLE(6,4,3) = 4.168825812144024E-2
      CEC_TABLE(6,5,3) = 8.364384007724771E-3


      SUBROUTINE PHO_SASVMD(Iset,Kf,X,Q2,P2,Alam,Xpga,Vxpga)
      IMPLICIT NONE
      REAL aem , aem2pi , Alam , alam3 , alam5 , P2 , p2div , p2eff ,
     &     pmb , pmc , Q2 , q2div , q2eff , s , s2 , s3 , s4 , sbt ,
     &     sch , sll
      REAL Vxpga , X , x1 , xbot , xchm , xglu , xl , Xpga , xsea ,
     &     xsea0 , xval
      INTEGER Iset , Kf , kfa , kfl , nfp , nfq
C...Purpose: to evaluate the VMD parton distributions of a photon,
C...evolved homogeneously from an initial scale P2 to Q2.
C...Does not include dipole suppression factor.
C...ISET is parton distribution set, see above;
C...additionally ISET=0 is used for the evolution of an anomalous photon
C...which branched at a scale P2 and then evolved homogeneously to Q2.
C...ALAM is the 4-flavour Lambda, which is automatically converted
C...to 3- and 5-flavour equivalents as needed.
      SAVE
      DIMENSION Xpga(-6:6) , Vxpga(-6:6)

C  input/output channels
      INCLUDE 'inc/poinou'

      DATA pmc/1.3/ , pmb/4.6/ , aem/0.007297/ , aem2pi/0.0011614/

C...Reset output.
      DO kfl = -6 , 6
         Xpga(kfl) = 0.
         Vxpga(kfl) = 0.
      END DO
      kfa = ABS(Kf)

C...Calculate Lambda; protect against unphysical Q2 and P2 input.
      alam3 = Alam*(pmc/Alam)**(2./27.)
      alam5 = Alam*(Alam/pmb)**(2./23.)
      p2eff = MAX(P2,1.2*alam3**2)
      IF ( kfa.EQ.4 ) p2eff = MAX(p2eff,pmc**2)
      IF ( kfa.EQ.5 ) p2eff = MAX(p2eff,pmb**2)
      q2eff = MAX(Q2,p2eff)

C...Find number of flavours at lower and upper scale.
      nfp = 4
      IF ( p2eff.LT.pmc**2 ) nfp = 3
      IF ( p2eff.GT.pmb**2 ) nfp = 5
      nfq = 4
      IF ( q2eff.LT.pmc**2 ) nfq = 3
      IF ( q2eff.GT.pmb**2 ) nfq = 5

C...Find s as sum of 3-, 4- and 5-flavour parts.
      s = 0.
      IF ( nfp.EQ.3 ) THEN
         q2div = pmc**2
         IF ( nfq.EQ.3 ) q2div = q2eff
         s = s + (6./27.)*LOG(LOG(q2div/alam3**2)/LOG(p2eff/alam3**2))
      END IF
      IF ( nfp.LE.4 .AND. nfq.GE.4 ) THEN
         p2div = p2eff
         IF ( nfp.EQ.3 ) p2div = pmc**2
         q2div = q2eff
         IF ( nfq.EQ.5 ) q2div = pmb**2
         s = s + (6./25.)*LOG(LOG(q2div/Alam**2)/LOG(p2div/Alam**2))
      END IF
      IF ( nfq.EQ.5 ) THEN
         p2div = pmb**2
         IF ( nfp.EQ.5 ) p2div = p2eff
         s = s + (6./23.)*LOG(LOG(q2eff/alam5**2)/LOG(p2div/alam5**2))
      END IF

C...Calculate frequent combinations of x and s.
      x1 = 1. - X
      xl = -LOG(X)
      s2 = s**2
      s3 = s**3
      s4 = s**4

C...Evaluate homogeneous anomalous parton distributions below or
C...above threshold.
      IF ( Iset.EQ.0 ) THEN
         IF ( Q2.LE.P2 .OR. (kfa.EQ.4 .AND. Q2.LT.pmc**2) .OR.
     &        (kfa.EQ.5 .AND. Q2.LT.pmb**2) ) THEN
            xval = X*1.5*(X**2+x1**2)
            xglu = 0.
            xsea = 0.
         ELSE
            xval = (1.5/(1.-0.197*s+4.33*s2)*X**2+(1.5+2.10*s)
     &             /(1.+3.29*s)*x1**2+5.23*s/(1.+1.17*s+19.9*s3)*X*x1)
     &             *X**(1./(1.+1.5*s))*(1.-X**2)**(2.667*s)
            xglu = 4.*s/(1.+4.76*s+15.2*s2+29.3*s4)
     &             *X**(-2.03*s/(1.+2.44*s))*(x1*xl)**(1.333*s)
     &             *((4.*X**2+7.*X+4.)*x1/3.-2.*X*(1.+X)*xl)
            xsea = s2/(1.+4.54*s+8.19*s2+8.05*s3)
     &             *X**(-1.54*s/(1.+1.29*s))*x1**(2.667*s)
     &             *((8.-73.*X+62.*X**2)*x1/9.+(3.-8.*X**2/3.)
     &             *X*xl+(2.*X-1.)*X*xl**2)
         END IF

C...Evaluate set 1D parton distributions below or above threshold.
      ELSE IF ( Iset.EQ.1 ) THEN
         IF ( Q2.LE.P2 .OR. (kfa.EQ.4 .AND. Q2.LT.pmc**2) .OR.
     &        (kfa.EQ.5 .AND. Q2.LT.pmb**2) ) THEN
            xval = 1.294*X**0.80*x1**0.76
            xglu = 1.273*X**0.40*x1**1.76
            xsea = 0.100*x1**3.76
         ELSE
            xval = 1.294/(1.+0.252*s+3.079*s2)*X**(0.80-0.13*s)
     &             *x1**(0.76+0.667*s)*xl**(2.*s)
            xglu = 7.90*s/(1.+5.50*s)*EXP(-5.16*s)
     &             *X**(-1.90*s/(1.+3.60*s))*x1**1.30*xl**(0.50+3.*s)
     &             + 1.273*EXP(-10.*s)*X**0.40*x1**(1.76+3.*s)
            xsea = (0.1-0.397*s2+1.121*s3)/(1.+5.61*s2+5.26*s3)
     &             *X**(-7.32*s2/(1.+10.3*s2))
     &             *x1**((3.76+15.*s+12.*s2)/(1.+4.*s))
            xsea0 = 0.100*x1**3.76
         END IF

C...Evaluate set 1M parton distributions below or above threshold.
      ELSE IF ( Iset.EQ.2 ) THEN
         IF ( Q2.LE.P2 .OR. (kfa.EQ.4 .AND. Q2.LT.pmc**2) .OR.
     &        (kfa.EQ.5 .AND. Q2.LT.pmb**2) ) THEN
            xval = 0.8477*X**0.51*x1**1.37
            xglu = 3.42*X**0.255*x1**2.37
            xsea = 0.
         ELSE
            xval = 0.8477/(1.+1.37*s+2.18*s2+3.73*s3)*X**(0.51+0.21*s)
     &             *x1**1.37*xl**(2.667*s)
            xglu = 24.*s/(1.+9.6*s+0.92*s2+14.34*s3)*EXP(-5.94*s)
     &             *X**((-0.013-1.80*s)/(1.+3.14*s))*x1**(2.37+0.4*s)
     &             *xl**(0.32+3.6*s) + 3.42*EXP(-12.*s)
     &             *X**0.255*x1**(2.37+3.*s)
            xsea = 0.842*s/(1.+21.3*s-33.2*s2+229.*s3)
     &             *X**((0.13-2.90*s)/(1.+5.44*s))*x1**(3.45+0.5*s)
     &             *xl**(2.8*s)
            xsea0 = 0.
         END IF

C...Evaluate set 2D parton distributions below or above threshold.
      ELSE IF ( Iset.EQ.3 ) THEN
         IF ( Q2.LE.P2 .OR. (kfa.EQ.4 .AND. Q2.LT.pmc**2) .OR.
     &        (kfa.EQ.5 .AND. Q2.LT.pmb**2) ) THEN
            xval = X**0.46*x1**0.64 + 0.76*X
            xglu = 1.925*x1**2
            xsea = 0.242*x1**4
         ELSE
            xval = (1.+0.186*s)/(1.-0.209*s+1.495*s2)*X**(0.46+0.25*s)
     &             *x1**((0.64+0.14*s+5.*s2)/(1.+s))*xl**(1.9*s)
     &             + (0.76+0.4*s)*X*x1**(2.667*s)
            xglu = (1.925+5.55*s+147.*s2)/(1.-3.59*s+3.32*s2)
     &             *EXP(-18.67*s)
     &             *X**((-5.81*s-5.34*s2)/(1.+29.*s-4.26*s2))
     &             *x1**((2.-5.9*s)/(1.+1.7*s))*xl**(9.3*s/(1.+1.7*s))
            xsea = (0.242-0.252*s+1.19*s2)/(1.-0.607*s+21.95*s2)
     &             *X**(-12.1*s2/(1.+2.62*s+16.7*s2))*x1**4*xl**s
            xsea0 = 0.242*x1**4
         END IF

C...Evaluate set 2M parton distributions below or above threshold.
      ELSE IF ( Iset.EQ.4 ) THEN
         IF ( Q2.LE.P2 .OR. (kfa.EQ.4 .AND. Q2.LT.pmc**2) .OR.
     &        (kfa.EQ.5 .AND. Q2.LT.pmb**2) ) THEN
            xval = 1.168*X**0.50*x1**2.60 + 0.965*X
            xglu = 1.808*x1**2
            xsea = 0.209*x1**4
         ELSE
            xval = (1.168+1.771*s+29.35*s2)*EXP(-5.776*s)
     &             *X**((0.5+0.208*s)/(1.-0.794*s+1.516*s2))
     &             *x1**((2.6+7.6*s)/(1.+5.*s))*xl**(5.15*s/(1.+2.*s))
     &             + (0.965+22.35*s)/(1.+18.4*s)*X*x1**(2.667*s)
            xglu = (1.808+29.9*s)/(1.+26.4*s)*EXP(-5.28*s)
     &             *X**((-5.35*s-10.11*s2)/(1.+31.71*s))
     &             *x1**((2.-7.3*s+4.*s2)/(1.+2.5*s))
     &             *xl**(10.9*s/(1.+2.5*s))
            xsea = (0.209+0.644*s2)/(1.+0.319*s+17.6*s2)
     &             *X**((-0.373*s-7.71*s2)/(1.+0.815*s+11.0*s2))
     &             *x1**(4.+s)*xl**(0.45*s)
            xsea0 = 0.209*x1**4
         END IF
      END IF

C...Threshold factors for c and b sea.
      sll = LOG(LOG(q2eff/Alam**2)/LOG(p2eff/Alam**2))
      xchm = 0.
      IF ( Q2.GT.pmc**2 .AND. Q2.GT.1.001*p2eff ) THEN
         sch = MAX(0.,LOG(LOG(pmc**2/Alam**2)/LOG(p2eff/Alam**2)))
         IF ( Iset.EQ.0 ) THEN
            xchm = xsea*(1.-(sch/sll)**2)
         ELSE
            xchm = MAX(0.,xsea-xsea0*x1**(2.667*s))*(1.-sch/sll)
         END IF
      END IF
      xbot = 0.
      IF ( Q2.GT.pmb**2 .AND. Q2.GT.1.001*p2eff ) THEN
         sbt = MAX(0.,LOG(LOG(pmb**2/Alam**2)/LOG(p2eff/Alam**2)))
         IF ( Iset.EQ.0 ) THEN
            xbot = xsea*(1.-(sbt/sll)**2)
         ELSE
            xbot = MAX(0.,xsea-xsea0*x1**(2.667*s))*(1.-sbt/sll)
         END IF
      END IF

C...Fill parton distributions.
      Xpga(0) = xglu
      Xpga(1) = xsea
      Xpga(2) = xsea
      Xpga(3) = xsea
      Xpga(4) = xchm
      Xpga(5) = xbot
      Xpga(kfa) = Xpga(kfa) + xval
      DO kfl = 1 , 5
         Xpga(-kfl) = Xpga(kfl)
      END DO
      Vxpga(kfa) = xval
      Vxpga(-kfa) = xval

      END SUBROUTINE


	FUNCTION PR_SKYX  ( skyc, drct, sped )
C************************************************************************
C* PR_SKYX								*
C*									*
C* This function combines the sky coverage symbol number with the   	*
C* wind speed (m/s or knots) and direction in degrees.			*
C* The following equation is used:					*
C*									*
C* SKYX = NINT ( SKYC ) + NINT ( SPED ) * 10000 + NINT ( DRCT ) * 10	*
C*									*
C* REAL PR_SKYX  ( SKYC, DRCT, SPED )					*
C*									*
C* Input parameters:							*
C*	SKYC		REAL 		Sky coverage			*
C*	DRCT		REAL		Wind direction in degrees	*
C*	SPED		REAL		Wind speed 			*
C*									*
C* Output parameters:							*
C*	PR_SKYX		REAL		Packed speed and direction	*
C**									*
C* Log:									*
C* K. Brill/NMC		12/91						*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for missing data.
C
	IF  ( ( .not. ERMISS ( skyc ) ) .and.
     +	      ( .not. ERMISS ( drct ) ) .and.
     +	      ( .not. ERMISS ( sped ) ) )  THEN
	    jdrct   = NINT ( drct )
	    jsped   = NINT ( sped )
	    jskyc   = NINT ( skyc )
	    PR_SKYX = jdrct * 10 + jsped * 10000 + jskyc
	  ELSE
	    PR_SKYX = RMISSD
	END IF
C*
	RETURN
	END


Subroutine vucharlength(                                    &
  ! Read only (unmodifiable) variables:
  nblock, nfieldv, nprops, ncomp, ndim, nnode, nstatev,     &
  kSecPt, kLayer, kIntPt, jElType, jElem,                   &
  totalTime, stepTime, dt,                                  &
  cmname, coordMp, coordNode, direct, T, props,             &
  field, stateOld,                                          &
  ! Write only (modifiable) variables:
  charLength )

  Implicit Double Precision (a-h, o-z)
  Integer, parameter :: j_sys_Dimension = 2, n_vec_Length = 136, maxblk = n_vec_Length

  Dimension jElType(3), jElem(nblock), coordMp(nblock,ndim),  &
    coordNode(nblock,nnode,ndim),                             &
    direct(nblock,3,3), T(nblock,3,3), props(nprops),         &
    stateOld(nblock,nstatev), charLength(nblock,ncomp),       &
    field(nblock, nfieldv)

  Character(len=80) :: cmname

  Double Precision :: center(ndim)

  ! Parameters
  Double Precision, parameter :: zero=0.d0, one=1.d0, two=2.d0

  Master: Do k = 1, nblock

    ! Center is the geometric center of the nodes
    center = zero
    Do n = 1, nnode
      center(:) = center(:) + coordNode(k, n, :)
    End Do
    center(:) = center(:) / nnode

    ! The characteristic element lengths are calculated as the averaged length from the geometric center to each node,
    ! projected onto the material directions (direct)
    charLength(k, :) = zero
    Nodes: Do n = 1, nnode
      Dimensions: Do d = 1, ndim
        charLength(k, d) = charLength(k, d) + ABS(DOT_PRODUCT(coordNode(k, n, :) - center(:), direct(k, :, d)))
      End Do Dimensions
    End Do Nodes
    charLength(k, :) = charLength(k, :) * two / nnode

    ! TODO: incorporate the data in T(nblock,3,3) for use in shell and membrane elements. This version may only be
    ! working for shells where the material direction is set to theta = zero degrees.

    ! Material point coordinates in the material frame (for random initial fiber misalignments)
    If (ncomp == 6) Then
      charLength(k, 4) = DOT_PRODUCT(coordMp(k,:), direct(k,:,1))
      charLength(k, 5) = DOT_PRODUCT(coordMp(k,:), direct(k,:,2))
      charLength(k, 6) = DOT_PRODUCT(coordMp(k,:), direct(k,:,3))
    End If

  End Do Master

  Return
End Subroutine vucharlength


!***********************************/
!	Name:保存変数から基礎変数へ変換するプログラム
!	Alias:UConserve2Primitive
!	Description:定義通りに計算するだけ
!	Type:Geom,CellCenter
!	Input:Geom,CC
!	Output:CC%PrimitiveVariable
!	Note:1~3次元すべてに対応済み
!	Author:Akitaka Toyota
!	Date:2017.11.11
!	Update:2017.11.11
!	Other:
!***********************************/
subroutine UConserve2Primitive(UG,UCC)
    use StructVar_Mod
    use LoopVar_Mod
    use ConstantVar_Mod, Gamma => SpecificOfHeatRatio
    implicit none
    type(UnstructuredGrid), intent(in) :: UG
    type(CellCenter),intent(inout) :: UCC

    iDim = UG%GM%Dimension

!$omp parallel num_threads(CoreNumberOfCPU),shared(UG,UCC,iDim),firstprivate(iCell)
!$omp do
    do iCell=1, UG%GI%AllCells
        UCC%PrimitiveVariable(1,iCell,1,1) = UCC%ConservedQuantity(1,iCell,1,1)

        UCC%PrimitiveVariable(2:iDim+1,iCell,1,1) = &
            &   UCC%ConservedQuantity(2:iDim+1,iCell,1,1)/UCC%ConservedQuantity(1,iCell,1,1)

        UCC%PrimitiveVariable(iDim+2,iCell,1,1) = &
            &   Gmin1 * (UCC%ConservedQuantity(iDim+2,iCell,1,1) - 0.5d0 * UCC%ConservedQuantity(1,iCell,1,1) &
            &   * dot_product(UCC%PrimitiveVariable(2:iDim+1,iCell,1,1),UCC%PrimitiveVariable(2:iDim+1,iCell,1,1)))

    end do
!$omp end do
!$omp end parallel
return
end subroutine UConserve2Primitive


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      SUBROUTINE EXSIDE (MXND, XN, YN, LNODES, ANGLE, N1, XNEW, YNEW)
C***********************************************************************

C  SUBROUTINE EXSIDE = CALCULATES A POSITION AN AVERAGE LENGTH AWAY
C                      FROM A SIDE NODE

C***********************************************************************

      DIMENSION XN (MXND), YN (MXND), LNODES (7, MXND), ANGLE (MXND)

      N0 = LNODES (2, N1)
      N2 = LNODES (3, N1)

      ANG = ATAN2 (YN (N2) - YN (N1),  XN (N2) - XN (N1)) +
     &   (ANGLE (N1) * .5)

      DIST1 = SQRT ( (YN (N2) - YN (N1) ) **2 +
     &   ( XN (N2) - XN (N1) ) **2)
      DIST2 = SQRT ( (YN (N0) - YN (N1) ) **2 +
     &   ( XN (N0) - XN (N1) ) **2)

      DIST =  (DIST1 + DIST2) * .5
      XNEW =  (DIST * COS (ANG) ) + XN (N1)
      YNEW =  (DIST * SIN (ANG) ) + YN (N1)

      RETURN

      END


subroutine dtcon

! set the timestep using various constraints.
! NB - additional constraints may be required depending on the problem!
!-----------------------------------------------------------------------

! GLOBALS
use global
use zone

IMPLICIT NONE

! LOCALS
INTEGER :: i, j, k
REAL(kind=8) ::  ridt, dtx, dt3, xvel, yvel, zvel, widthy, widthz

!------------------------------------------------------------------------
!   Hydro constraint on timestep.  Use R*d(theta) if y geometry is angular
ridt = 0.

if(ndim==1) then
  do i = 1, imax
    xvel = abs(zux(i,1,1)) / zdx(i)
    ridt = max(xvel,ridt)
  enddo
else if(ndim==2) then
  do j = 1, jmax
   do i = 1, imax
     widthy = zdy(j)
     if(ngeomy > 2) widthy = widthy*zxc(i)
     xvel = abs(zux(i,j,1)) / zdx(i)
     yvel = abs(zuy(i,j,1)) / widthy
     ridt = max(xvel,yvel,ridt)
   enddo
  enddo
else if(ndim==3) then
  do k = 1, kmax
   do j = 1, jmax
    do i = 1, imax
      widthy = zdy(j)
      widthz = zdz(k)
      if(ngeomy >  2) widthy = widthy*zxc(i)
      if(ngeomz >  2) widthz = widthz*zxc(i)
      if(ngeomz == 5) widthz = widthz*sin(zyc(j))
      xvel = abs(zux(i,j,k)) / zdx(i)
      yvel = abs(zuy(i,j,k)) / widthy
      zvel = abs(zuz(i,j,k)) / widthz
      ridt = max(xvel,yvel,zvel,ridt)
    enddo
   enddo
  enddo
endif

ridt = max(svel,ridt)
dtx  = courant / ridt     ! global time constraint for given courant parameter
dt3  = 1.1 * dt           ! limiting constraint on rate of increase of dt
dt   = min( dt3, dtx )    ! use smallest required timestep

if (time/dt > 1.e7) then   ! if timestep becomes too small, stop the program!
  write(*,*) 'Timestep has become too small: dt = ',dt
  write(*,*) '                             time = ',time
  call prin('ABORT')
  stop
endif

return
end


      PRINT (10 + 15 + 25)^2 * 4
      END


Subroutine xkksan(i1, i2, srt, sigks1, sigks2, sigks3, sigks4, sigk, prkk)
  Parameter (aka=0.498, pimass=0.140, rhom=0.770, aks=0.895, omegam=0.7819, etam=0.5473)
  Parameter (maxstr=150001)
  Common /cc/e(maxstr)
  Save
  s = srt**2
  sigks1 = 1.E-08
  sigks2 = 1.E-08
  sigks3 = 1.E-08
  sigks4 = 1.E-08
  xpion0 = prkk
  xpion0 = xpion0/2
  pi2 = (s-(e(i1)+e(i2))**2)*(s-(e(i1)-e(i2))**2)
  sigk = 1.E-08
  If (pi2<=0.0) Return
  xm1 = pimass
  xm2 = rhom
  pf2 = (s-(xm1+xm2)**2)*(s-(xm1-xm2)**2)
  If (pi2>0.0 .And. pf2>0.0) Then
    sigks1 = 27.0/4.0*pf2/pi2*xpion0
  End If
  xm1 = pimass
  xm2 = omegam
  pf2 = (s-(xm1+xm2)**2)*(s-(xm1-xm2)**2)
  If (pi2>0.0 .And. pf2>0.0) Then
    sigks2 = 9.0/4.0*pf2/pi2*xpion0
  End If
  xm1 = rhom
  xm2 = etam
  pf2 = (s-(xm1+xm2)**2)*(s-(xm1-xm2)**2)
  If (pf2>0.0) Then
    sigks3 = 9.0/4.0*pf2/pi2*xpion0
  End If
  xm1 = omegam
  xm2 = etam
  pf2 = (s-(xm1+xm2)**2)*(s-(xm1-xm2)**2)
  If (pf2>0.0) Then
    sigks4 = 3.0/4.0*pf2/pi2*xpion0
  End If
  sigk = sigks1 + sigks2 + sigks3 + sigks4
  Return
End Subroutine xkksan


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2015 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine mechmodel(elconloc,elas,emec,kode,emec0,ithermal,
     &     icmd,beta,stre,xkl,ckl,vj,xikl,vij,plconloc,xstate,xstateini,
     &     ielas,amat,t1l,dtime,time,ttime,iel,iint,nstate_,mi,
     &     iorien,pgauss,orab,eloc,mattyp,pnewdt,istep,iinc,ipkon,
     &     nmethod,iperturb)
!
!     kode=-1: Arruda-Boyce
!          -2: Mooney-Rivlin
!          -3: Neo-Hooke
!          -4: Ogden (N=1)
!          -5: Ogden (N=2)
!          -6: Ogden (N=3)
!          -7: Polynomial (N=1)
!          -8: Polynomial (N=2)
!          -9: Polynomial (N=3)
!          -10: Reduced Polynomial (N=1)
!          -11: Reduced Polynomial (N=2)
!          -12: Reduced Polynomial (N=3)
!          -13: Van der Waals (not implemented yet)
!          -14: Yeoh
!          -15: Hyperfoam (N=1)
!          -16: Hyperfoam (N=2)
!          -17: Hyperfoam (N=3)
!          -50: deformation plasticity
!          -51: incremental plasticity (no viscosity)
!          -52: viscoplasticity
!       < -100: user material routine with -kode-100 user
!               defined constants with keyword *USER MATERIAL
!
      implicit none
!
      character*80 amat
!
      integer kode,ithermal,icmd,ielas,iel,iint,nstate_,mi(*),iorien,
     &  mattyp,istep,iinc,ipkon(*),nmethod,iperturb(*)
!
      real*8 elconloc(*),elas(21),emec(*),emec0(*),beta(*),stre(*),
     &  ckl(*),vj,plconloc(*),t1l,xkl(*),xikl(*),vij,
     &  dtime,didc(27),d2idc2(243),dibdc(27),d2ibdc2(243),
     &  dudc(9),d2udc2(81),dldc(27),d2ldc2(243),dlbdc(27),d2lbdc2(243),
     &  pgauss(3),orab(7,*),time,ttime,eloc(6),pnewdt
!
      real*8 xstate(nstate_,mi(1),*),xstateini(nstate_,mi(1),*)
!
      if(kode.gt.0) then
         call linel(kode,mattyp,beta,emec,stre,elas,elconloc,
     &  iorien,orab,pgauss)
      elseif(kode.gt.-50) then
         mattyp=3
         call rubber(elconloc,elas,emec,kode,didc,d2idc2,
     &     dibdc,d2ibdc2,dudc,d2udc2,dldc,d2ldc2,dlbdc,d2lbdc2,
     &     ithermal,icmd,beta,stre)
      elseif(kode.eq.-50) then
         mattyp=3
         call defplas(elconloc,elas,emec,ithermal,icmd,beta,stre,
     &     ckl,vj)
      elseif(kode.gt.-100) then
         mattyp=3
         if(iperturb(2).eq.1) then
            call incplas(elconloc,plconloc,xstate,xstateini,elas,emec,
     &           ithermal,icmd,beta,stre,vj,kode,ielas,amat,t1l,dtime,
     &           time,ttime,iel,iint,nstate_,mi(1),eloc,pgauss,nmethod,
     &           pnewdt)
         else
            call incplas_lin(elconloc,plconloc,xstate,xstateini,elas,
     &           emec,
     &           ithermal,icmd,beta,stre,vj,kode,ielas,amat,t1l,dtime,
     &           time,ttime,iel,iint,nstate_,mi(1),eloc,pgauss,nmethod,
     &           pnewdt)
         endif
      else
         mattyp=3
         call umat_main(amat,iel,iint,kode,elconloc,emec,emec0,beta,
     &        xikl,vij,xkl,vj,ithermal,t1l,dtime,time,ttime,icmd,ielas,
     &        mi(1),nstate_,xstateini,xstate,stre,elas,iorien,pgauss,
     &        orab,pnewdt,istep,iinc,ipkon,nmethod,iperturb)
      endif
!
      return
      end


c$Header: /data/petsun4/data1/src_solaris/imglin/RCS/grad_opt.f,v 1.1 2007/09/05 04:05:45 avi Exp $
c$Log: grad_opt.f,v $
c Revision 1.1  2007/09/05  04:05:45  avi
c Initial revision
c
      subroutine grad_opt(imgt,nx,ny,nz,mmppix,center,param,x0,grad,xopt,ierr)
      real*4 imgt(nx,ny,nz)
      real*4 mmppix(3),center(3),x0(3),grad(3),xopt(3)
      real*4 param(16)
c     param(01:03)	normal to osculating plane (used by edge_trace)
c     param(04)		del arclength              (used by edge_trace)
c     param(05)		sigma eval
      real*4 coef(0:2),array(3,3)
      parameter (nk=3)
      parameter (npts=2*nk+1)
      real*4 u(-nk:nk),v(-nk-1:nk+1),dv(-nk:nk)
      real*4 x(3),unorm(3),e(3)
      logical*4 lfar,liter
      logical*4 ldebug/.false./

c     copy x0 into xopt	as inital guess
      do i=1,3
        xopt(i)=x0(i)
      enddo

      do 10 ncycle=1,5
      if(ldebug)write (*,"('x0 grad_opt ',3f10.4)")x0

      nnn=0
      niter=5
   83 liter=.false.
      lfar=.false.

c     compute gradient
      do i=1,3
        do k=1,3
          x(k)=xopt(k)
        enddo
        x(i)=xopt(i)+0.5*param(05)
        call imgvalx(imgt,nx,ny,nz,center,mmppix,x,v2,lslice)
        if(lslice.le.0)goto 99
        x(i)=xopt(i)-0.5*param(05)
        call imgvalx(imgt,nx,ny,nz,center,mmppix,x,v1,lslice)
        if(lslice.le.0)goto 99
        grad(i)=(v2-v1)/param(05)
      enddo

c     compute unit normal
      a=sqrt(dot(grad,grad))
      do i=1,3
        unorm(i)=-grad(i)/a
      enddo
c     write (*, "('unit normal',3f10.4)")unorm

      do 9 k=-nk-1,nk+1			! sample image along normal
      do i=1,3
        x(i)=xopt(i)-param(05)*unorm(i)*(float(k)/float(nk))
      enddo
      call imgvalx(imgt,nx,ny,nz,center,mmppix,x,v(k),lslice)
      if(lslice.le.0)goto 99
c     write (*, "('imgvalx x,v',3f7.2,f9.1)",x,v(k)
    9 continue
      do 8 k=-nk,nk			! differentiate
      u(k)=float(k)/float(nk)
    8 dv(k)=v(k+1)-v(k-1)
c     write (*,"('dv',10f9.1)")dv

      call polfit(u,dv,npts,coef,array,3,chisqr)
c     write (*,"('coef ',3g12.4)",coef
      t=-.5*coef(1)/coef(2)
      if(coef(2).gt.0..or.abs(t).gt.0.5)then
        t0=t
        t=sign(.5,coef(1))
        if(ldebug)write(*,"('t ',f10.6,' ->',f10.6)")t0,t
        lfar=.true.
      endif
      liter=liter.or.abs(t).gt.0.02
      do i=1,3
        xopt(i)=xopt(i)-t*param(05)*unorm(i)
      enddo
      nnn=nnn+1
      if(nnn.gt.20)then
        write(*,"('failed convergence')")
        ierr=1
        return
      endif
      if(.not.lfar)then
        niter=niter-1
      endif
      if(liter.and.niter.gt.0)goto 83

c     write (*,"('xopt       ',3f10.4)")xopt
      do i=1,3
        e(i)=x0(i)-xopt(i)
      enddo
      dist=dot(unorm,e)
      do i=1,3
        xopt(i)=x0(i)-dist*unorm(i)
      enddo
c     write (*,"('xopt new   ',3f10.4)")xopt
   10 continue
      ierr=0
      return

   99 write (*,"('grad_opt: image boundary reached')")
      ierr=-1
      return
      end