*
*     -------------------------------------------------------------
*      S I X J 3
*     -------------------------------------------------------------
*
*                                                                  *
*     THIS PACKAGE DETERMINES THE VALUES OF 6j COEFFICIENT         *
*                                                                  *
*     | J/2  K/2  L/2 |                                            *
*     | M/2  N/2   2  |             [B.M.X. 75]                    *
*                                                                  *
*     Written by G. Gaigalas,                                      *
*     Vanderbilt University,  Nashville             October 1996   *
*
*
*
      SUBROUTINE SIXJ3(J,K,L,M,N,ITIK,SI)
      IMPLICIT DOUBLEPRECISION (A-H,O-Z)
      COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS
      SI=ZERO
      IF(ITIK.NE.0) THEN
C
C     CHESKED TRIANGULAR CONDITIONS
C
        IF(IXJTIK(J,K,L,M,N,6).EQ.0)RETURN
      ENDIF
      I1=(J+K+L)/2
      AS=DBLE(I1)
      A=DBLE(L)
      B=DBLE(J)
      C=DBLE(K)
      AKA=ONE
      IF(MOD(I1,2).NE.0)AKA=-AKA
      IF(J-N.EQ.6) THEN
* -3
        IF(K-M.EQ.6) THEN
C                        -3  -3
          SI=AKA*DSQRT((AS+ONE)*AS*(AS-ONE)*(AS-TWO)*(AS-THREE)*
     :    (AS-FOUR)/
     :    ((B+ONE)*B*(B-ONE)*(B-TWO)*(B-THREE)*(B-FOUR)*(B-THREE-TWO)))
          SI=SI*DSQRT((AS-A-THREE-TWO)*(AS-A-FOUR)*
     :    (AS-A-THREE)*(AS-A-TWO)*(AS-A-ONE)*(AS-A)/
     :    ((C+ONE)*C*(C-ONE)*(C-TWO)*(C-THREE)*(C-FOUR)*(C-THREE-TWO)))
        ELSEIF(M-K.EQ.6) THEN
C                        3  -3
          SI=AKA*DSQRT((AS-C)*(AS-C-ONE)*(AS-C-TWO)*(AS-C-THREE)*
     :    (AS-C-FOUR)*(AS-C-THREE-TWO)/
     :    ((B+ONE)*B*(B-ONE)*(B-TWO)*(B-THREE)*(B-FOUR)*(B-THREE-TWO)))
          SI=SI*DSQRT((AS-B+THREE+THREE)*(AS-B+THREE+TWO)*(AS-B+FOUR)*
     :    (AS-B+THREE)*(AS-B+TWO)*(AS-B+ONE)/
     :    ((C+FOUR+THREE)*(C+THREE+THREE)*(C+THREE+TWO)*(C+FOUR)*
     :    (C+THREE)*(C+TWO)*(C+ONE)))
        ELSEIF(K-M.EQ.4) THEN
C                       -2  -3
	  SI=AKA*DSQRT(TWO*THREE*(AS-C)*(AS-B+ONE)*(AS-THREE)*
     :    (AS-TWO)*(AS-ONE)*AS*(AS+ONE)/
     :    ((B-THREE-TWO)*(B-FOUR)*(B-THREE)*(B-TWO)*(B-ONE)*B*(B+ONE)))
	  SI=SI*DSQRT((AS-A-FOUR)*(AS-A-THREE)*(AS-A-TWO)*(AS-A-ONE)*
     :    (AS-A)/
     :    ((C-FOUR)*(C-THREE)*(C-TWO)*(C-ONE)*C*(C+ONE)*(C+TWO)))
        ELSEIF(M-K.EQ.4) THEN
C                        2  -3
	  SI=AKA*DSQRT(TWO*THREE*(AS+ONE)*(AS-A)*
     :    (AS-C-FOUR)*(AS-C-THREE)*(AS-C-TWO)*(AS-C-ONE)*(AS-C)/
     :    ((C+THREE+THREE)*(C+THREE+TWO)*(C+FOUR)*
     :    (C+THREE)*(C+TWO)*(C+ONE)*C))
	  SI=SI*DSQRT((AS-B+THREE+TWO)*(AS-B+FOUR)*(AS-B+THREE)*
     :    (AS-B+TWO)*(AS-B+ONE)/
     :    ((B-THREE-TWO)*(B-FOUR)*(B-THREE)*(B-TWO)*(B-ONE)*B*(B+ONE)))
        ELSEIF(K-M.EQ.2) THEN
C                       -1   -3
	  SI=AKA*DSQRT(THREE*(THREE+TWO)*(AS-C)*(AS-C-ONE)*(AS-B+TWO)*
     :    (AS-B+ONE)*(AS-TWO)*(AS-ONE)*AS*(AS+ONE)/
     :    ((B-THREE-TWO)*(B-FOUR)*(B-THREE)*(B-TWO)*(B-ONE)*B*(B+ONE)))
	  SI=SI*DSQRT((AS-A-THREE)*(AS-A-TWO)*(AS-A-ONE)*(AS-A)/
     :    ((C-THREE)*(C-TWO)*(C-ONE)*C*(C+ONE)*(C+TWO)*(C+THREE)))
        ELSEIF(M-K.EQ.2) THEN
C                        1   -3
	  SI=AKA*DSQRT(THREE*(THREE+TWO)*(AS+ONE)*AS*(AS-A-ONE)*
     :    (AS-A)*(AS-C-THREE)*(AS-C-TWO)*(AS-C-ONE)*(AS-C)/
     :    ((B-THREE-TWO)*(B-FOUR)*(B-THREE)*(B-TWO)*(B-ONE)*B*(B+ONE)))
          SI=SI*DSQRT((AS-B+FOUR)*(AS-B+THREE)*(AS-B+TWO)*(AS-B+ONE)/
     :    ((C+THREE+TWO)*(C+FOUR)*(C+THREE)*(C+TWO)*(C+ONE)*C*(C-ONE)))
        ELSEIF(M-K.EQ.0) THEN
C                        0   -3
	  SI=AKA*TWO*DSQRT((THREE+TWO)*(AS+ONE)*AS*(AS-ONE)*
     :    (AS-A-TWO)*(AS-A-ONE)*(AS-A)/
     :    ((B-THREE-TWO)*(B-FOUR)*(B-THREE)*(B-TWO)*(B-ONE)*B*(B+ONE)))
          SI=SI*DSQRT((AS-C-TWO)*(AS-C-ONE)*(AS-C)*(AS-B+THREE)*
     :    (AS-B+TWO)*(AS-B+ONE)/
     :    ((C+FOUR)*(C+THREE)*(C+TWO)*(C+ONE)*C*(C-ONE)*(C-TWO)))
        ENDIF
      ELSEIF(N-J.EQ.6) THEN
*  3
        IF(K-M.EQ.6) THEN
C                        -3  3
          SI=AKA*DSQRT((AS-B)*(AS-B-ONE)*(AS-B-TWO)*(AS-B-THREE)*
     :    (AS-B-FOUR)*(AS-B-THREE-TWO)/
     :    ((C+ONE)*C*(C-ONE)*(C-TWO)*(C-THREE)*(C-FOUR)*(C-THREE-TWO)))
          SI=SI*DSQRT((AS-C+THREE+THREE)*(AS-C+THREE+TWO)*(AS-C+FOUR)*
     :    (AS-C+THREE)*(AS-C+TWO)*(AS-C+ONE)/
     :    ((B+FOUR+THREE)*(B+THREE+THREE)*(B+THREE+TWO)*(B+FOUR)*
     :    (B+THREE)*(B+TWO)*(B+ONE)))
        ELSEIF(M-K.EQ.6) THEN
C                        3   3
	  SI=AKA*DSQRT((AS-A+THREE+THREE)*(AS-A+THREE+TWO)*
     :    (AS-A+FOUR)*(AS-A+THREE)*(AS-A+TWO)*(AS-A+ONE)/
     :    ((B+SEVEN)*(B+THREE+THREE)*(B+THREE+TWO)*(B+FOUR)*
     :    (B+THREE)*(B+TWO)*(B+ONE)))
          SI=SI*DSQRT((AS+SEVEN)*(AS+THREE+THREE)*(AS+THREE+TWO)*
     :    (AS+FOUR)*(AS+THREE)*(AS+TWO)/
     :    ((C+SEVEN)*(C+THREE+THREE)*(C+THREE+TWO)*(C+FOUR)*
     :    (C+THREE)*(C+TWO)*(C+ONE)))
        ELSEIF(K-M.EQ.4) THEN
C                       -2   3
	  SI=-AKA*DSQRT(TWO*THREE*(AS-A+ONE)*(AS+TWO)*(AS-B-FOUR)*
     :    (AS-B-THREE)*(AS-B-TWO)*(AS-B-ONE)*(AS-B)/
     :    ((B+SEVEN)*(B+THREE+THREE)*(B+THREE+TWO)*(B+FOUR)*
     :    (B+THREE)*(B+TWO)*(B+ONE)))
	  SI=SI*DSQRT((AS-C+THREE+TWO)*(AS-C+FOUR)*(AS-C+THREE)*
     :    (AS-C+TWO)*(AS-C+ONE)/
     :    ((C-FOUR)*(C-THREE)*(C-TWO)*(C-ONE)*C*(C+ONE)*(C+TWO)))
        ELSEIF(M-K.EQ.4) THEN
C                        2   3
	  SI=-AKA*DSQRT(TWO*THREE*(AS-B)*(AS-C+ONE)*
     :    (AS-A+THREE+TWO)*(AS-A+FOUR)*(AS-A+THREE)*(AS-A+TWO)*
     :    (AS-A+ONE)/
     :    ((B+SEVEN)*(B+THREE+THREE)*(B+THREE+TWO)*(B+FOUR)*
     :    (B+THREE)*(B+TWO)*(B+ONE)))
	  SI=SI*DSQRT((AS+THREE+THREE)*(AS+THREE+TWO)*(AS+FOUR)*
     :    (AS+THREE)*(AS+TWO)/
     :    ((C+THREE+THREE)*(C+THREE+TWO)*(C+FOUR)*(C+THREE)*(C+TWO)*
     :    (C+ONE)*C))
        ELSEIF(K-M.EQ.2) THEN
C                       -1   3
	  SI=AKA*DSQRT(THREE*(THREE+TWO)*(AS-A+ONE)*(AS-A+TWO)*
     :    (AS+THREE)*
     :    (AS+TWO)*(AS-B-THREE)*(AS-B-TWO)*(AS-B-ONE)*(AS-B)/
     :    ((B+SEVEN)*(B+THREE+THREE)*(B+THREE+TWO)*(B+FOUR)*(B+THREE)*
     :    (B+TWO)*(B+ONE)))
          SI=SI*DSQRT((AS-C+FOUR)*(AS-C+THREE)*(AS-C+TWO)*(AS-C+ONE)/
     :    ((C-THREE)*(C-TWO)*(C-ONE)*C*(C+ONE)*(C+TWO)*(C+THREE)))
        ELSEIF(M-K.EQ.2) THEN
C                        1   3
	  SI=AKA*DSQRT(THREE*(THREE+TWO)*(AS-B)*(AS-B-ONE)*(AS-C+TWO)*
     :    (AS-C+ONE)*(AS-A+FOUR)*(AS-A+THREE)*(AS-A+TWO)*(AS-A+ONE)/
     :    ((B+SEVEN)*(B+THREE+THREE)*(B+THREE+TWO)*(B+FOUR)*(B+THREE)*
     :    (B+TWO)*(B+ONE)))
          SI=SI*DSQRT((AS+THREE+TWO)*(AS+FOUR)*(AS+THREE)*(AS+TWO)/
     :    ((C+THREE+TWO)*(C+FOUR)*(C+THREE)*(C+TWO)*(C+ONE)*C*(C-ONE)))
        ELSEIF(M-K.EQ.0) THEN
C                        0   3
	  SI=-AKA*TWO*DSQRT((THREE+TWO)*(AS-B)*(AS-B-ONE)*(AS-B-TWO)*
     :    (AS-C+THREE)*(AS-C+TWO)*(AS-C+ONE)/
     :    ((B+SEVEN)*(B+THREE+THREE)*(B+THREE+TWO)*(B+FOUR)*
     :    (B+THREE)*(B+TWO)*(B+ONE)))
          SI=SI*DSQRT((AS-A+THREE)*(AS-A+TWO)*(AS-A+ONE)*
     :    (AS+FOUR)*(AS+THREE)*(AS+TWO)/
     :    ((C+FOUR)*(C+THREE)*(C+TWO)*(C+ONE)*C*(C-ONE)*(C-TWO)))
	ENDIF
      ELSEIF(J-N.EQ.4) THEN
* -2
        IF(K-M.EQ.6) THEN
C                       -3  -2
	  SI=AKA*DSQRT(TWO*THREE*(AS-B)*(AS-C+ONE)*(AS-THREE)*
     :    (AS-TWO)*(AS-ONE)*AS*(AS+ONE)/
     :    ((C-THREE-TWO)*(C-FOUR)*(C-THREE)*(C-TWO)*(C-ONE)*C*(C+ONE)))
	  SI=SI*DSQRT((AS-A-FOUR)*(AS-A-THREE)*(AS-A-TWO)*(AS-A-ONE)*
     :    (AS-A)/
     :    ((B-FOUR)*(B-THREE)*(B-TWO)*(B-ONE)*B*(B+ONE)*(B+TWO)))
        ELSEIF(M-K.EQ.6) THEN
C                       3   -2
	  SI=-AKA*DSQRT(TWO*THREE*(AS-A+ONE)*(AS+TWO)*(AS-C-FOUR)*
     :    (AS-C-THREE)*(AS-C-TWO)*(AS-C-ONE)*(AS-C)/
     :    ((C+SEVEN)*(C+THREE+THREE)*(C+THREE+TWO)*(C+FOUR)*
     :    (C+THREE)*(C+TWO)*(C+ONE)))
	  SI=SI*DSQRT((AS-B+THREE+TWO)*(AS-B+FOUR)*(AS-B+THREE)*
     :    (AS-B+TWO)*(AS-B+ONE)/
     :    ((B-FOUR)*(B-THREE)*(B-TWO)*(B-ONE)*B*(B+ONE)*(B+TWO)))
        ELSEIF(K-M.EQ.4) THEN
C                      -2  -2
	  SI=AKA*((TWO+THREE)*(AS-C)*(AS-B)-(AS+TWO)*(AS-A-FOUR))*
     :    DSQRT((AS-TWO)*(AS-ONE)*AS*(AS+ONE)/
     :    ((B-FOUR)*(B-THREE)*(B-TWO)*(B-ONE)*B*(B+ONE)*(B+TWO)))
	  SI=SI*DSQRT((AS-A-THREE)*(AS-A-TWO)*(AS-A-ONE)*(AS-A)/
     :    ((C-FOUR)*(C-THREE)*(C-TWO)*(C-ONE)*C*(C+ONE)*(C+TWO)))
        ELSEIF(M-K.EQ.4) THEN
C                       2  -2
	  SI=-AKA*((TWO+THREE)*(AS+ONE)*(AS-A+ONE)-(AS-C+ONE)*
     :    (AS-B+THREE+TWO))*
     :    DSQRT((AS-C-THREE)*(AS-C-TWO)*(AS-C-ONE)*(AS-C)/
     :    ((B-FOUR)*(B-THREE)*(B-TWO)*(B-ONE)*B*(B+ONE)*(B+TWO)))
	  SI=SI*DSQRT((AS-B+FOUR)*(AS-B+THREE)*(AS-B+TWO)*(AS-B+ONE)/
     :    ((C+THREE+THREE)*(C+THREE+TWO)*(C+FOUR)*(C+THREE)*(C+TWO)*
     :    (C+ONE)*C))
        ELSEIF(K-M.EQ.2) THEN
C                       -1  -2
	  SI=AKA*(TWO*(AS-C-ONE)*(AS-B)-(AS+TWO)*(AS-A-THREE))*
     :    DSQRT(TWO*(THREE+TWO)*(AS-C)*(AS-B+ONE)*(AS-ONE)*AS*
     :    (AS+ONE)/
     :    ((B-FOUR)*(B-THREE)*(B-TWO)*(B-ONE)*B*(B+ONE)*(B+TWO)))
	  SI=SI*DSQRT((AS-A-TWO)*(AS-A-ONE)*(AS-A)/
     :    ((C-THREE)*(C-TWO)*(C-ONE)*C*(C+ONE)*(C+TWO)*(C+THREE)))
        ELSEIF(M-K.EQ.2) THEN
C                        1  -2
	  SI=-AKA*(TWO*AS*(AS-A+ONE)-(AS-C+ONE)*(AS-B+FOUR))*
     :    DSQRT(TWO*(THREE+TWO)*(AS+ONE)*(AS-A)*(AS-C-TWO)*
     :    (AS-C-ONE)*(AS-C)/
     :    ((B-FOUR)*(B-THREE)*(B-TWO)*(B-ONE)*B*(B+ONE)*(B+TWO)))
	  SI=SI*DSQRT((AS-B+THREE)*(AS-B+TWO)*(AS-B+ONE)/
     :    ((C+THREE+TWO)*(C+FOUR)*(C+THREE)*(C+TWO)*(C+ONE)*C*(C-ONE)))
        ELSEIF(M-K.EQ.0) THEN
C                        0  -2
	  SI=-AKA*((AS-ONE)*(AS-A+ONE)-(AS-C+ONE)*(AS-B+THREE))*
     :    DSQRT(TWO*THREE*(THREE+TWO)*(AS+ONE)*AS*(AS-A-ONE)*(AS-A)/
     :    ((B-FOUR)*(B-THREE)*(B-TWO)*(B-ONE)*B*(B+ONE)*(B+TWO)))
	  SI=SI*DSQRT((AS-C-ONE)*(AS-C)*(AS-B+TWO)*(AS-B+ONE)/
     :    ((C+FOUR)*(C+THREE)*(C+TWO)*(C+ONE)*C*(C-ONE)*(C-TWO)))
	ENDIF
      ELSEIF(N-J.EQ.4) THEN
*  2
        IF(K-M.EQ.6) THEN
C                        -3  2
	  SI=AKA*DSQRT(TWO*THREE*(AS+ONE)*(AS-A)*
     :    (AS-B-FOUR)*(AS-B-THREE)*(AS-B-TWO)*(AS-B-ONE)*(AS-B)/
     :    ((B+THREE+THREE)*(B+THREE+TWO)*(B+FOUR)*
     :    (B+THREE)*(B+TWO)*(B+ONE)*B))
	  SI=SI*DSQRT((AS-C+THREE+TWO)*(AS-C+FOUR)*(AS-C+THREE)*
     :    (AS-C+TWO)*(AS-C+ONE)/
     :    ((C-THREE-TWO)*(C-FOUR)*(C-THREE)*(C-TWO)*(C-ONE)*C*(C+ONE)))
        ELSEIF(M-K.EQ.6) THEN
C                        3  2
	  SI=-AKA*DSQRT(TWO*THREE*(AS-C)*(AS-B+ONE)*
     :    (AS-A+THREE+TWO)*(AS-A+FOUR)*(AS-A+THREE)*(AS-A+TWO)*
     :    (AS-A+ONE)/
     :    ((C+SEVEN)*(C+THREE+THREE)*(C+THREE+TWO)*(C+FOUR)*
     :    (C+THREE)*(C+TWO)*(C+ONE)))
	  SI=SI*DSQRT((AS+THREE+THREE)*(AS+THREE+TWO)*(AS+FOUR)*
     :    (AS+THREE)*(AS+TWO)/
     :    ((B+THREE+THREE)*(B+THREE+TWO)*(B+FOUR)*(B+THREE)*(B+TWO)*
     :    (B+ONE)*B))
        ELSEIF(K-M.EQ.4) THEN
C                       -2  2
	  SI=-AKA*((TWO+THREE)*(AS+ONE)*(AS-A+ONE)-(AS-B+ONE)*
     :    (AS-C+THREE+TWO))*
     :    DSQRT((AS-B-THREE)*(AS-B-TWO)*(AS-B-ONE)*(AS-B)/
     :    ((C-FOUR)*(C-THREE)*(C-TWO)*(C-ONE)*C*(C+ONE)*(C+TWO)))
	  SI=SI*DSQRT((AS-C+FOUR)*(AS-C+THREE)*(AS-C+TWO)*(AS-C+ONE)/
     :    ((B+THREE+THREE)*(B+THREE+TWO)*(B+FOUR)*(B+THREE)*(B+TWO)*
     :    (B+ONE)*B))
        ELSEIF(M-K.EQ.4) THEN
C                        2  2
	  SI=AKA*((TWO+THREE)*(AS-B)*(AS-C)-(AS-A)*(AS+THREE+THREE))*
     :    DSQRT((AS-A+FOUR)*(AS-A+THREE)*(AS-A+TWO)*(AS-A+ONE)/
     :    ((B+THREE+THREE)*(B+THREE+TWO)*(B+FOUR)*(B+THREE)*(B+TWO)*
     :    (B+ONE)*B))
	  SI=SI*DSQRT((AS+THREE+TWO)*(AS+FOUR)*(AS+THREE)*(AS+TWO)/
     :    ((C+THREE+THREE)*(C+THREE+TWO)*(C+FOUR)*(C+THREE)*(C+TWO)*
     :    (C+ONE)*C))
        ELSEIF(K-M.EQ.2) THEN
C                       -1  2
	  SI=AKA*(TWO*(AS-A+TWO)*(AS+ONE)-(AS-B+ONE)*(AS-C+FOUR))*
     :    DSQRT(TWO*(THREE+TWO)*(AS-A+ONE)*(AS+TWO)*(AS-B-TWO)*
     :    (AS-B-ONE)*(AS-B)/
     :    ((B+THREE+THREE)*(B+THREE+TWO)*(B+FOUR)*(B+THREE)*(B+TWO)*
     :    (B+ONE)*B))
	  SI=SI*DSQRT((AS-C+THREE)*(AS-C+TWO)*(AS-C+ONE)/
     :    ((C-THREE)*(C-TWO)*(C-ONE)*C*(C+ONE)*(C+TWO)*(C+THREE)))
        ELSEIF(M-K.EQ.2) THEN
C                        1  2
	  SI=-AKA*(TWO*(AS-B-ONE)*(AS-C)-(AS-A)*(AS+THREE+TWO))*
     :    DSQRT(TWO*(THREE+TWO)*(AS-B)*(AS-C+ONE)*(AS-A+THREE)*
     :    (AS-A+TWO)*(AS-A+ONE)/
     :    ((B+THREE+THREE)*(B+THREE+TWO)*(B+FOUR)*(B+THREE)*(B+TWO)*
     :    (B+ONE)*B))
	  SI=SI*DSQRT((AS+FOUR)*(AS+THREE)*(AS+TWO)/
     :    ((C+THREE+TWO)*(C+FOUR)*(C+THREE)*(C+TWO)*(C+ONE)*C*(C-ONE)))
        ELSEIF(M-K.EQ.0) THEN
C                        0  2
	  SI=AKA*((AS-B-TWO)*(AS-C)-(AS-A)*(AS+FOUR))*
     :    DSQRT(TWO*THREE*(THREE+TWO)*(AS-B)*(AS-B-ONE)*(AS-C+TWO)*
     :    (AS-C+ONE)/
     :    ((B+THREE+THREE)*(B+THREE+TWO)*(B+FOUR)*(B+THREE)*(B+TWO)*
     :    (B+ONE)*B))
	  SI=SI*DSQRT((AS-A+TWO)*(AS-A+ONE)*(AS+THREE)*(AS+TWO)/
     :    ((C+FOUR)*(C+THREE)*(C+TWO)*(C+ONE)*C*(C-ONE)*(C-TWO)))
	ENDIF
      ELSEIF(J-N.EQ.2) THEN
* - 1
        IF(K-M.EQ.6) THEN
C                       -3   -1
	  SI=AKA*DSQRT(THREE*(THREE+TWO)*(AS-B)*(AS-B-ONE)*(AS-C+TWO)*
     :    (AS-C+ONE)*(AS-TWO)*(AS-ONE)*AS*(AS+ONE)/
     :    ((C-THREE-TWO)*(C-FOUR)*(C-THREE)*(C-TWO)*(C-ONE)*C*(C+ONE)))
	  SI=SI*DSQRT((AS-A-THREE)*(AS-A-TWO)*(AS-A-ONE)*(AS-A)/
     :    ((B-THREE)*(B-TWO)*(B-ONE)*B*(B+ONE)*(B+TWO)*(B+THREE)))
        ELSEIF(M-K.EQ.6) THEN
C                       3    -1
	  SI=AKA*DSQRT(THREE*(THREE+TWO)*(AS-A+ONE)*(AS-A+TWO)*
     :    (AS+THREE)*
     :    (AS+TWO)*(AS-C-THREE)*(AS-C-TWO)*(AS-C-ONE)*(AS-C)/
     :    ((C+SEVEN)*(C+THREE+THREE)*(C+THREE+TWO)*(C+FOUR)*(C+THREE)*
     :    (C+TWO)*(C+ONE)))
          SI=SI*DSQRT((AS-B+FOUR)*(AS-B+THREE)*(AS-B+TWO)*(AS-B+ONE)/
     :    ((B-THREE)*(B-TWO)*(B-ONE)*B*(B+ONE)*(B+TWO)*(B+THREE)))
        ELSEIF(K-M.EQ.4) THEN
C                       -2   -1
	  SI=AKA*(TWO*(AS-B-ONE)*(AS-C)-(AS+TWO)*(AS-A-THREE))*
     :    DSQRT(TWO*(THREE+TWO)*(AS-B)*(AS-C+ONE)*(AS-ONE)*AS*
     :    (AS+ONE)/
     :    ((C-FOUR)*(C-THREE)*(C-TWO)*(C-ONE)*C*(C+ONE)*(C+TWO)))
	  SI=SI*DSQRT((AS-A-TWO)*(AS-A-ONE)*(AS-A)/
     :    ((B-THREE)*(B-TWO)*(B-ONE)*B*(B+ONE)*(B+TWO)*(B+THREE)))
        ELSEIF(M-K.EQ.4) THEN
C                       2    -1
	  SI=AKA*(TWO*(AS-A+TWO)*(AS+ONE)-(AS-C+ONE)*(AS-B+FOUR))*
     :    DSQRT(TWO*(THREE+TWO)*(AS-A+ONE)*(AS+TWO)*(AS-C-TWO)*
     :    (AS-C-ONE)*(AS-C)/
     :    ((C+THREE+THREE)*(C+THREE+TWO)*(C+FOUR)*(C+THREE)*(C+TWO)*
     :    (C+ONE)*C))
	  SI=SI*DSQRT((AS-B+THREE)*(AS-B+TWO)*(AS-B+ONE)/
     :    ((B-THREE)*(B-TWO)*(B-ONE)*B*(B+ONE)*(B+TWO)*(B+THREE)))
        ELSEIF(K-M.EQ.2) THEN
C                        -1   -1
	  SI=AKA*((TWO*THREE*(AS-C)*(AS-C-ONE)*(AS-B-ONE)*(AS-B))-
     :    (TWO*FOUR*(AS-C)*(AS-B)*(AS+TWO)*(AS-A-TWO))+
     :    ((AS+THREE)*(AS+TWO)*(AS-A-THREE)*(AS-A-TWO)))
          SI=SI*DSQRT(AS*(AS+ONE)*(AS-A-ONE)*(AS-A)/
     :    ((B-THREE)*(B-TWO)*(B-ONE)*B*(B+ONE)*(B+TWO)*(B+THREE)*
     :    (C-THREE)*(C-TWO)*(C-ONE)*C*(C+ONE)*(C+TWO)*(C+THREE)))
        ELSEIF(M-K.EQ.2) THEN
C                         1   -1
	  SI=AKA*((TWO*THREE*(AS+ONE)*AS*(AS-A+ONE)*(AS-A+TWO))-
     :    (TWO*FOUR*(AS+ONE)*(AS-A+ONE)*(AS-C+ONE)*(AS-B+THREE))+
     :    ((AS-C+ONE)*(AS-C+TWO)*(AS-B+FOUR)*(AS-B+THREE)))
          SI=SI*DSQRT((AS-C-ONE)*(AS-C)*(AS-B+TWO)*(AS-B+ONE)/
     :    ((B-THREE)*(B-TWO)*(B-ONE)*B*(B+ONE)*(B+TWO)*(B+THREE)*
     :    (C+THREE+TWO)*(C+FOUR)*(C+THREE)*(C+TWO)*(C+ONE)*C*(C-ONE)))
        ELSEIF(M-K.EQ.0) THEN
C                         0   -1
	  SI=AKA*TWO*((AS*(AS-ONE)*(AS-A+ONE)*(AS-A+TWO))-
     :    (THREE*AS*(AS-A+ONE)*(AS-C+ONE)*(AS-B+TWO))+
     :    ((AS-C+ONE)*(AS-C+TWO)*(AS-B+THREE)*(AS-B+TWO)))
          SI=SI*DSQRT(THREE*(AS+ONE)*(AS-A)*(AS-C)*(AS-B+ONE)/
     :    ((B-THREE)*(B-TWO)*(B-ONE)*B*(B+ONE)*(B+TWO)*(B+THREE)*
     :    (C+FOUR)*(C+THREE)*(C+TWO)*(C+ONE)*C*(C-ONE)*(C-TWO)))
        ENDIF
      ELSEIF(N-J.EQ.2) THEN
* - 1
        IF(K-M.EQ.6) THEN
C                        -3   1
	  SI=AKA*DSQRT(THREE*(THREE+TWO)*(AS+ONE)*AS*(AS-A-ONE)*
     :    (AS-A)*(AS-B-THREE)*(AS-B-TWO)*(AS-B-ONE)*(AS-B)/
     :    ((C-THREE-TWO)*(C-FOUR)*(C-THREE)*(C-TWO)*(C-ONE)*C*(C+ONE)))
          SI=SI*DSQRT((AS-C+FOUR)*(AS-C+THREE)*(AS-C+TWO)*(AS-C+ONE)/
     :    ((B+THREE+TWO)*(B+FOUR)*(B+THREE)*(B+TWO)*(B+ONE)*B*(B-ONE)))
        ELSEIF(M-K.EQ.6) THEN
C                        3    1
	  SI=AKA*DSQRT(THREE*(THREE+TWO)*(AS-C)*(AS-C-ONE)*(AS-B+TWO)*
     :    (AS-B+ONE)*(AS-A+FOUR)*(AS-A+THREE)*(AS-A+TWO)*(AS-A+ONE)/
     :    ((C+SEVEN)*(C+THREE+THREE)*(C+THREE+TWO)*(C+FOUR)*(C+THREE)*
     :    (C+TWO)*(C+ONE)))
          SI=SI*DSQRT((AS+THREE+TWO)*(AS+FOUR)*(AS+THREE)*(AS+TWO)/
     :    ((B+THREE+TWO)*(B+FOUR)*(B+THREE)*(B+TWO)*(B+ONE)*B*(B-ONE)))
        ELSEIF(K-M.EQ.4) THEN
C                        -2   1
	  SI=-AKA*(TWO*AS*(AS-A+ONE)-(AS-B+ONE)*(AS-C+FOUR))*
     :    DSQRT(TWO*(THREE+TWO)*(AS+ONE)*(AS-A)*(AS-B-TWO)*
     :    (AS-B-ONE)*(AS-B)/
     :    ((C-FOUR)*(C-THREE)*(C-TWO)*(C-ONE)*C*(C+ONE)*(C+TWO)))
	  SI=SI*DSQRT((AS-C+THREE)*(AS-C+TWO)*(AS-C+ONE)/
     :    ((B+THREE+TWO)*(B+FOUR)*(B+THREE)*(B+TWO)*(B+ONE)*B*(B-ONE)))
        ELSEIF(M-K.EQ.4) THEN
C                         2   1
	  SI=-AKA*(TWO*(AS-C-ONE)*(AS-B)-(AS-A)*(AS+THREE+TWO))*
     :    DSQRT(TWO*(THREE+TWO)*(AS-C)*(AS-B+ONE)*(AS-A+THREE)*
     :    (AS-A+TWO)*(AS-A+ONE)/
     :    ((C+THREE+THREE)*(C+THREE+TWO)*(C+FOUR)*(C+THREE)*(C+TWO)*
     :    (C+ONE)*C))
	  SI=SI*DSQRT((AS+FOUR)*(AS+THREE)*(AS+TWO)/
     :    ((B+THREE+TWO)*(B+FOUR)*(B+THREE)*(B+TWO)*(B+ONE)*B*(B-ONE)))
        ELSEIF(M-K.EQ.2) THEN
C                         1   1
	  SI=AKA*((TWO*THREE*(AS-B)*(AS-B-ONE)*(AS-C)*(AS-C-ONE))-
     :    (TWO*FOUR*(AS-B)*(AS-C)*(AS-A)*(AS+FOUR))+
     :    ((AS-A)*(AS-A-ONE)*(AS+THREE+TWO)*(AS+FOUR)))
          SI=SI*DSQRT((AS-A+TWO)*(AS-A+ONE)*(AS+THREE)*(AS+TWO)/
     :    ((B+THREE+TWO)*(B+FOUR)*(B+THREE)*(B+TWO)*(B+ONE)*B*(B-ONE)*
     :    (C+THREE+TWO)*(C+FOUR)*(C+THREE)*(C+TWO)*(C+ONE)*C*(C-ONE)))
        ELSEIF(K-M.EQ.2) THEN
C                        -1   1
	  SI=AKA*((TWO*THREE*(AS+ONE)*AS*(AS-A+ONE)*(AS-A+TWO))-
     :    (TWO*FOUR*(AS+ONE)*(AS-A+ONE)*(AS-B+ONE)*(AS-C+THREE))+
     :    ((AS-B+ONE)*(AS-B+TWO)*(AS-C+FOUR)*(AS-C+THREE)))
          SI=SI*DSQRT((AS-B-ONE)*(AS-B)*(AS-C+TWO)*(AS-C+ONE)/
     :    ((C-THREE)*(C-TWO)*(C-ONE)*C*(C+ONE)*(C+TWO)*(C+THREE)*
     :    (B+THREE+TWO)*(B+FOUR)*(B+THREE)*(B+TWO)*(B+ONE)*B*(B-ONE)))
        ELSEIF(M-K.EQ.0) THEN
C                         0   1
	  SI=-AKA*TWO*(((AS-B-ONE)*(AS-B-TWO)*(AS-C)*(AS-C-ONE))-
     :    (THREE*(AS-B-ONE)*(AS-C)*(AS-A)*(AS+THREE))+
     :    ((AS-A)*(AS-A-ONE)*(AS+FOUR)*(AS+THREE)))
          SI=SI*DSQRT(THREE*(AS-B)*(AS-C+ONE)*(AS-A+ONE)*(AS+TWO)/
     :    ((B+THREE+TWO)*(B+FOUR)*(B+THREE)*(B+TWO)*(B+ONE)*B*(B-ONE)*
     :    (C+FOUR)*(C+THREE)*(C+TWO)*(C+ONE)*C*(C-ONE)*(C-TWO)))
        ENDIF
      ELSEIF(J-N.EQ.0) THEN
*  0
        IF(K-M.EQ.6) THEN
C                       -3    0
	  SI=AKA*TWO*DSQRT((THREE+TWO)*(AS+ONE)*AS*(AS-ONE)*
     :    (AS-A-TWO)*(AS-A-ONE)*(AS-A)/
     :    ((C-THREE-TWO)*(C-FOUR)*(C-THREE)*(C-TWO)*(C-ONE)*C*(C+ONE)))
          SI=SI*DSQRT((AS-B-TWO)*(AS-B-ONE)*(AS-B)*(AS-C+THREE)*
     :    (AS-C+TWO)*(AS-C+ONE)/
     :    ((B+FOUR)*(B+THREE)*(B+TWO)*(B+ONE)*B*(B-ONE)*(B-TWO)))
        ELSEIF(M-K.EQ.6) THEN
C                        3    0
	  SI=-AKA*TWO*DSQRT((THREE+TWO)*(AS-C)*(AS-C-ONE)*(AS-C-TWO)*
     :    (AS-B+THREE)*(AS-B+TWO)*(AS-B+ONE)/
     :    ((C+SEVEN)*(C+THREE+THREE)*(C+THREE+TWO)*(C+FOUR)*
     :    (C+THREE)*(C+TWO)*(C+ONE)))
          SI=SI*DSQRT((AS-A+THREE)*(AS-A+TWO)*(AS-A+ONE)*
     :    (AS+FOUR)*(AS+THREE)*(AS+TWO)/
     :    ((B+FOUR)*(B+THREE)*(B+TWO)*(B+ONE)*B*(B-ONE)*(B-TWO)))
        ELSEIF(K-M.EQ.4) THEN
C                       -2    0
	  SI=-AKA*((AS-ONE)*(AS-A+ONE)-(AS-B+ONE)*(AS-C+THREE))*
     :    DSQRT(TWO*THREE*(THREE+TWO)*(AS+ONE)*AS*(AS-A-ONE)*(AS-A)/
     :    ((C-FOUR)*(C-THREE)*(C-TWO)*(C-ONE)*C*(C+ONE)*(C+TWO)))
	  SI=SI*DSQRT((AS-B-ONE)*(AS-B)*(AS-C+TWO)*(AS-C+ONE)/
     :    ((B+FOUR)*(B+THREE)*(B+TWO)*(B+ONE)*B*(B-ONE)*(B-TWO)))
        ELSEIF(M-K.EQ.4) THEN
C                        2    0
	  SI=AKA*((AS-C-TWO)*(AS-B)-(AS-A)*(AS+FOUR))*
     :    DSQRT(TWO*THREE*(THREE+TWO)*(AS-C)*(AS-C-ONE)*(AS-B+TWO)*
     :    (AS-B+ONE)/
     :    ((C+THREE+THREE)*(C+THREE+TWO)*(C+FOUR)*(C+THREE)*(C+TWO)*
     :    (C+ONE)*C))
	  SI=SI*DSQRT((AS-A+TWO)*(AS-A+ONE)*(AS+THREE)*(AS+TWO)/
     :    ((B+FOUR)*(B+THREE)*(B+TWO)*(B+ONE)*B*(B-ONE)*(B-TWO)))
        ELSEIF(K-M.EQ.2) THEN
C                       -1    0
	  SI=AKA*TWO*((AS*(AS-ONE)*(AS-A+ONE)*(AS-A+TWO))-
     :    (THREE*AS*(AS-A+ONE)*(AS-B+ONE)*(AS-C+TWO))+
     :    ((AS-B+ONE)*(AS-B+TWO)*(AS-C+THREE)*(AS-C+TWO)))
          SI=SI*DSQRT(THREE*(AS+ONE)*(AS-A)*(AS-B)*(AS-C+ONE)/
     :    ((C-THREE)*(C-TWO)*(C-ONE)*C*(C+ONE)*(C+TWO)*(C+THREE)*
     :    (B+FOUR)*(B+THREE)*(B+TWO)*(B+ONE)*B*(B-ONE)*(B-TWO)))
        ELSEIF(M-K.EQ.2) THEN
C                        1    0
	  SI=-AKA*TWO*(((AS-C-ONE)*(AS-C-TWO)*(AS-B)*(AS-B-ONE))-
     :    (THREE*(AS-C-ONE)*(AS-B)*(AS-A)*(AS+THREE))+
     :    ((AS-A)*(AS-A-ONE)*(AS+FOUR)*(AS+THREE)))
          SI=SI*DSQRT(THREE*(AS-C)*(AS-B+ONE)*(AS-A+ONE)*(AS+TWO)/
     :    ((C+THREE+TWO)*(C+FOUR)*(C+THREE)*(C+TWO)*(C+ONE)*C*(C-ONE)*
     :    (B+FOUR)*(B+THREE)*(B+TWO)*(B+ONE)*B*(B-ONE)*(B-TWO)))
        ELSEIF(K-M.EQ.0) THEN
C                        0    0
	  SI=AKA*(((AS-B)*(AS-B-ONE)*(AS-B-TWO)*(AS-C)*(AS-C-ONE)*
     :    (AS-C-TWO))-
     :    (THREE*THREE*(AS-B)*(AS-B-ONE)*(AS-C)*(AS-C-ONE)*(AS-A)*
     :    (AS+TWO))+
     :    (THREE*THREE*(AS-B)*(AS-C)*(AS-A)*(AS-A-ONE)*(AS+THREE)*
     :    (AS+TWO))-
     :    ((AS-A)*(AS-A-ONE)*(AS-A-TWO)*(AS+FOUR)*(AS+THREE)*(AS+TWO)))
          SI=SI/DSQRT((B+FOUR)*(B+THREE)*(B+TWO)*(B+ONE)*B*(B-ONE)*
     :    (B-TWO)*(C+FOUR)*(C+THREE)*(C+TWO)*(C+ONE)*C*(C-ONE)*(C-TWO))
        ENDIF
      ENDIF
      RETURN
      END


      subroutine plantparm_init

      use basin_module
      use maximum_data_module
      use plant_data_module

      implicit none

      integer :: ic           !none        |counter
      real :: c1              !            |
      real :: b1              !            |
      real :: b2              !            |
      real :: b3              !            |

      do ic = 1, db_mx%plantparm
        if (pldb(ic)%bm_dieoff <= 1.e-6) pldb(ic)%bm_dieoff = 1.00

        !! set default value
        if (pldb(ic)%ext_coef < 1.e-6) pldb(ic)%ext_coef = 0.65
        if (pldb(ic)%rsdco_pl < 1.e-6) pldb(ic)%rsdco_pl = bsn_prm%rsdco
        if (pldb(ic)%usle_c <= 0.0) pldb(ic)%usle_c = 0.0
        if (pldb(ic)%usle_c >= 1.0) pldb(ic)%usle_c = 1.0
        if (pldb(ic)%blai <= 0.0) pldb(ic)%blai = 0.0
        if (pldb(ic)%blai >= 10.0) pldb(ic)%blai = 10.0
	    if (pldb(ic)%rsr1 <= 0.0) pldb(ic)%rsr1 = 0.4
	    if (pldb(ic)%rsr2 <= 0.0) pldb(ic)%rsr2 = 0.2

        if (pldb(ic)%bio_e > 0. .and. pldb(ic)%plantnm /= "WATR") then

!!        determine shape parameters for the plant population-lai equation
          if (pldb(ic)%pop1 + pldb(ic)%pop2 > 1.e-6) then
            pldb(ic)%pop1 = pldb(ic)%pop1 / 1001.
            pldb(ic)%pop2 = pldb(ic)%pop2 / 1001.
            call ascrv(pldb(ic)%frlai1,pldb(ic)%frlai2,                     &
              pldb(ic)%pop1,pldb(ic)%pop2,plcp(ic)%popsc1,plcp(ic)%popsc2)
          end if
!!        determine shape parameters for the leaf area development equation
          call ascrv(pldb(ic)%laimx1,pldb(ic)%laimx2,pldb(ic)%frgrw1,       &
              pldb(ic)%frgrw2,plcp(ic)%leaf1,plcp(ic)%leaf2)

!!        The other point used to determine shape parameters for radiation
!!        use efficiency is the ambient CO2 level (330 ul/l) and the
!!        biomass-energy ratio (bio_e) given for the crop/land cover.
          c1 = 330.                        !! ambient CO2
          if (pldb(ic)%co2hi == 330.) pldb(ic)%co2hi = 660.
          b1 = pldb(ic)%bio_e * .01        !! "ambient" bio-e ratio/100
          b2 = pldb(ic)%bioehi * .01                !! "elevated" bio-e ratio/100

!!        determine shape parameters for the radiation use efficiency equation
          call ascrv(b1, b2, c1, pldb(ic)%co2hi, plcp(ic)%ruc1,             &
              plcp(ic)%ruc2)

          if (pldb(ic)%usle_c < 1.e-4) pldb(ic)%usle_c = 0.001
          plcp(ic)%cvm = Log(pldb(ic)%usle_c)

!!        nitrogen uptake parameters
!!        fix bad input for pltnfr(3,ic)
          if (pldb(ic)%pltnfr1 - pldb(ic)%pltnfr2 < .0001)                  &
                         pldb(ic)%pltnfr2 = pldb(ic)%pltnfr1 - .0001
          if (pldb(ic)%pltnfr2 - pldb(ic)%pltnfr3 < .0001)                  &
                         pldb(ic)%pltnfr3 = .75 * pldb(ic)%pltnfr3
          b1 = pldb(ic)%pltnfr1 - pldb(ic)%pltnfr3   !!normalize N fractions
          b2 = 1. - (pldb(ic)%pltnfr2 - pldb(ic)%pltnfr3) / b1
          b3 = 1. - .00001 / b1
!!        determine shape parameters for plant nitrogen uptake equation
          call ascrv(b2, b3, 0.5, 1.0, plcp(ic)%nup1, plcp(ic)%nup2)

!!        phosphorus uptake parameters
!!        fix bad input for pltpfr3
          if (pldb(ic)%pltpfr1 - pldb(ic)%pltpfr2 < .0001)                  &
                         pldb(ic)%pltpfr2 = pldb(ic)%pltpfr1 - .0001
          if (pldb(ic)%pltpfr2 - pldb(ic)%pltpfr3 < .0001)                  &
                         pldb(ic)%pltpfr3 = .75 * pldb(ic)%pltpfr3
          b1 = pldb(ic)%pltpfr1 - pldb(ic)%pltpfr3     !!normalize P fractions
          b2 = 1. - (pldb(ic)%pltpfr2 - pldb(ic)%pltpfr3) / b1
          b3 = 1. - .00001 / b1
!!        determine shape parameters for plant phosphorus uptake equation
          call ascrv(b2, b3, .5, 1., plcp(ic)%pup1, plcp(ic)%pup2)

!!        calculate slope in stomatal conductance equation
          plcp(ic)%vpd2 = (1. - pldb(ic)%gmaxfr) / (pldb(ic)%vpdfr - 1.)

        end if

      end do

      return
      end subroutine plantparm_init


!> Routines related to the Lennard-Jones (12-6) interaction
!! lj_interaction.
module m_lj_interaction
  use m_lj, only: lj_potential, lj_from_json
  use m_point, only: point, pair_interaction
  use num_kind, only: dp
  use json_module
  use m_json_wrapper, only: get_parameter
  implicit none

  !> Wraps the Lennard-Jones potential as a pair_interaction.
  type, extends(pair_interaction) :: lj_interaction

     !> The Lennard-Jones potential.
     type(lj_potential) :: pef

     !> Cutoff radius of the interaction.
     real(dp) :: cutoff = 5.5

   contains

     !> Computes the energy of the interaction between two LJ particles.
     procedure :: pair_potential => lj_pair_potential

     !> Computes the force acting between two LJ particles.
     procedure :: pair_force => lj_pair_force

     !> Returns the cutoff radius of the interaction.
     procedure :: get_cutoff => lj_get_cutoff

     !> Serializes the interaction to JSON.
     procedure :: to_json => lj_to_json

     !> Produces a sample of the values of this interaction.
     procedure :: sample => lj_sample
  end type lj_interaction

  !> Contstuctor interface for the LJ interaction.
  interface lj_interaction
     module procedure lj_interaction_from_json
  end interface lj_interaction

contains

  !> Deserializes the lj_interaction from JSON value @p json_val.
  function lj_interaction_from_json(json_val) result(this)
    type(json_value), pointer, intent(in) :: json_val
    type(lj_interaction) :: this
    call get_parameter(json_val, 'r_cutoff', this%cutoff, error_lb=0._dp)
    this%pef = lj_potential(json_val)
  end function lj_interaction_from_json

  !> Serializes @p this interaction to JSON value @p json_val.
  subroutine lj_to_json(this, json_val)
    class(lj_interaction), intent(in) :: this
    type(json_value), pointer, intent(inout) :: json_val
    call json_add(json_val, 'r_cutoff', this%cutoff)
    call this%pef%to_json(json_val)
  end subroutine lj_to_json

  !> Computes the @p energy of @p this interaction for the particle pair
  !! @p particlei, @p particlej. @p rij is the vector from @p particlei
  !! to @p particlej. If @p err = 1 the particles are considered to
  !! overlap.
  pure subroutine lj_pair_potential(this, particlei, particlej, rij, &
       energy, err)
    class(lj_interaction), intent(in) :: this
    class(point), intent(in) :: particlei, particlej
    real(dp), intent(in) :: rij(3)
    real(dp), intent(out) :: energy
    integer, intent(out) :: err
    logical :: overlap
    err = 0
    call this%pef%potential(norm2(rij), energy, overlap)
    if (overlap) err = 1
  end subroutine lj_pair_potential

  !> Returns the cutoff radius of @p this interaction.
  pure function lj_get_cutoff(this) result(cutoff)
    class(lj_interaction), intent(in) :: this
    real(dp) :: cutoff
    cutoff = this%cutoff
  end function lj_get_cutoff

  !> Returns the force acting on @p particlei by the @p particlej due to
  !! @p this interaction. @p rij is the vector from @p particlei to
  !! @p particlej.
  pure function lj_pair_force(this, particlei, particlej, rij) result(f)
    class(lj_interaction), intent(in) :: this
    class(point), intent(in) :: particlei, particlej
    real(dp), intent(in) :: rij(3)
    real(dp) :: f(3)
    f = this%pef%force(rij)
  end function lj_pair_force

  !> Produces a sample of the possible potential energies of @p this
  !! interaction with particle-to-particle distances r. The sample is
  !! written to JSON value @p json_val.
  subroutine lj_sample(this, json_val, r)
    class(lj_interaction), intent(in) :: this
    type(json_value), pointer :: json_val
    type(point) :: lj
    real(dp), intent(in) :: r(:)
    type(json_value), pointer :: child
    real(dp) :: energy
    integer :: err, k
    type(json_value), pointer :: r_json, energy_json

    call json_create_object(json_val, 'lj_interaction')
    call json_create_object(child, 'LJ-LJ')
    call json_create_array(r_json, 'x')
    call json_create_array(energy_json, 'energy')
    do k = 1, size(r)
       call this%pair_potential(lj, lj, [r(k), 0._dp, 0._dp], energy, err)
       if (err == 0) then
          call json_add(r_json, '', r(k))
          call json_add(energy_json, '', energy)
       end if
    end do
    call json_add(child, r_json)
    call json_add(child, energy_json)
    call json_add(json_val, child)
  end subroutine lj_sample

end module m_lj_interaction


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

C=======================================================================
      LOGICAL FUNCTION MPROTA(ANGLE,AXIS)
      COMMON /MAP/MODEL(4,4),VIEW(4,4),PROJ(4,4),CPNEAR,CPFAR,VWPORT(4),
     *       MVP(4,4),VP(4,4),CPLINE(2,2,10),CPPLAN(2,3,10),PEYE(3),
     *       PLOOK(3),ETWIST,NCPLIN,NCPLAN,TMAT1(4,4),TMAT2(4,4),
     *       TMAT3(4,4),TVEC1(4),TVEC2(4),TVEC3(4),TVEC4(4),TARR1(32),
     *       TARR2(32),TARR3(32),TARR4(32),TARR5(32),TARR6(32),
     *       TARR7(32),TARR8(32)
      REAL MODEL,MVP
      CHARACTER*6 SUBNAM
      PARAMETER (SUBNAM='MPROTA')
      CHARACTER*1 AXIS,TAXIS
      PARAMETER (DPR=57.2958)

      MPROTA = .FALSE.
      CALL CHRUP(AXIS,TAXIS)
      IF (TAXIS.NE.'X' .AND. TAXIS.NE.'Y' .AND. TAXIS.NE.'Z') THEN
         CALL PLTFLU
         CALL SIORPT(SUBNAM,'Illegal axis '//AXIS//' specified',2)
         RETURN

      END IF

      MPROTA = .TRUE.
      CALL LDROTA(AXIS,COS(ANGLE/DPR),SIN(ANGLE/DPR),TMAT1)
      CALL MXCOPY(4,MODEL,TMAT2)
      CALL MXMULT(4,TMAT1,TMAT2,MODEL)
      CALL MXMULT(4,MODEL,VP,MVP)
      RETURN

      END


!==============================================================================!
  subroutine Multiphase_Mod_Vof_Surface_Tension_Contribution(mult)
!------------------------------------------------------------------------------!
!    Computes the Curvature based on old-fashioned Brackbill's CSF approach    !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Work_Mod, only: grad_kx   => r_cell_02,  & !grad on x of vof for curvature
                      grad_ky   => r_cell_03,  & !grad on y of vof for curvature
                      grad_kz   => r_cell_04,  & !grad on z of vof for curvature
                      grad_nx   => r_cell_05,  & !grad on x of vof for normal
                      grad_ny   => r_cell_06,  & !grad on y of vof for normal
                      grad_nz   => r_cell_07,  & !grad on z of vof for normal
                      vof_norm  => r_cell_08   ! normal
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Multiphase_Type), target :: mult
!-----------------------------------[Locals]-----------------------------------!
  type(Field_Type),pointer :: flow
  type(Grid_Type), pointer :: grid
  type(Var_Type),  pointer :: vof
  integer                  :: s, c, c1, c2, c_iter, nb, nc
  real                     :: vol_face, grad_face(3), grad_control(3)
  real                     :: dotprod, sxyz_mod, sxyz_control, fs, epsloc
  real                     :: d_n(3) !normal pointing to the wall
  real                     :: norm_grad !normal of a gradient
!==============================================================================!

  epsloc = epsilon(epsloc)

  ! First take aliases
  flow => mult % pnt_flow
  grid => mult % pnt_grid
  vof  => mult % vof
  nb   = grid % n_bnd_cells
  nc   = grid % n_cells

  if(mult % d_func) then  ! using distance function

    grad_kx = mult % dist_func % x
    grad_ky = mult % dist_func % y
    grad_kz = mult % dist_func % z

  else ! using VOF

    do c = -grid % n_bnd_cells, grid % n_cells
      mult % curv(c) = vof % n(c)
    end do

    do c_iter = 1, mult % n_conv_curv

      grad_kx = 0.0
      grad_ky = 0.0

      !-------------------------------!
      !   Extrapolate to boundaries   !
      !-------------------------------!

      do s = 1, grid % n_faces
        c1 = grid % faces_c(1,s)
        c2 = grid % faces_c(2,s)
        if (c2 < 0) then
          mult % curv(c2) = mult % curv(c1)
        end if
      end do

      ! Smoothing VOF
      do s = 1, grid % n_faces
        c1 = grid % faces_c(1,s)
        c2 = grid % faces_c(2,s)
        fs = grid % f(s)
        sxyz_mod = sqrt( grid % sx(s) ** 2   &
                       + grid % sy(s) ** 2   &
                       + grid % sz(s) ** 2)
        if (c2 > 0) then
          vol_face = fs * mult % curv(c1) + (1.0 - fs) * mult % curv(c2)
          grad_kx(c1) = grad_kx(c1) + vol_face * sxyz_mod
          grad_ky(c1) = grad_ky(c1) + sxyz_mod
          grad_kx(c2) = grad_kx(c2) + vol_face * sxyz_mod
          grad_ky(c2) = grad_ky(c2) + sxyz_mod
        else
          vol_face = mult % curv(c1)
          grad_kx(c1) = grad_kx(c1) + vol_face * sxyz_mod
          grad_ky(c1) = grad_ky(c1) + sxyz_mod
        end if
      end do

      call Grid_Mod_Exchange_Cells_Real(grid, grad_kx(-nb:nc))
      call Grid_Mod_Exchange_Cells_Real(grid, grad_ky(-nb:nc))

      do c = 1, grid % n_cells
        mult % curv(c) = grad_kx(c) / grad_ky(c)
      end do

      call Grid_Mod_Exchange_Cells_Real(grid, mult % curv)

      if (c_iter == mult % n_conv_norm) then  ! smooth for normal
        vof_norm = mult % curv
      end if
    end do

    ! Clean noise
    do c = 1, grid % n_cells
      if (mult % curv(c) < epsloc) then
        mult % curv(c) = 0.0
      end if
      if ((1.0 - mult % curv(c)) < epsloc) then
        mult % curv(c) = 1.0
      end if
    end do

    ! At boundaries
    do s = 1, grid % n_faces
      c1 = grid % faces_c(1,s)
      c2 = grid % faces_c(2,s)
      if (c2 < 0) then
        mult % curv(c2) = mult % curv(c1)
        vof_norm(c2) = vof_norm(c1)
      end if
    end do

    !-------------------!
    !   Find Gradient   !
    !-------------------!

    grad_kx = 0.0
    grad_ky = 0.0
    grad_kz = 0.0
    grad_nx = 0.0
    grad_ny = 0.0
    grad_nz = 0.0

    do s = 1, grid % n_faces
      c1 = grid % faces_c(1,s)
      c2 = grid % faces_c(2,s)
      fs = grid % f(s)
      if (c2 > 0) then
        vol_face = fs * mult % curv(c1) + (1.0 - fs) * mult % curv(c2)
        grad_kx(c1) = grad_kx(c1) + vol_face * grid % sx(s)
        grad_ky(c1) = grad_ky(c1) + vol_face * grid % sy(s)
        grad_kz(c1) = grad_kz(c1) + vol_face * grid % sz(s)

        grad_kx(c2) = grad_kx(c2) - vol_face * grid % sx(s)
        grad_ky(c2) = grad_ky(c2) - vol_face * grid % sy(s)
        grad_kz(c2) = grad_kz(c2) - vol_face * grid % sz(s)

        vol_face = fs * vof_norm(c1) + (1.0 - fs) * vof_norm(c2)
        grad_nx(c1) = grad_nx(c1) + vol_face * grid % sx(s)
        grad_ny(c1) = grad_ny(c1) + vol_face * grid % sy(s)
        grad_nz(c1) = grad_nz(c1) + vol_face * grid % sz(s)

        grad_nx(c2) = grad_nx(c2) - vol_face * grid % sx(s)
        grad_ny(c2) = grad_ny(c2) - vol_face * grid % sy(s)
        grad_nz(c2) = grad_nz(c2) - vol_face * grid % sz(s)
      else
        vol_face = mult % curv(c1)
        grad_kx(c1) = grad_kx(c1) + vol_face * grid % sx(s)
        grad_ky(c1) = grad_ky(c1) + vol_face * grid % sy(s)
        grad_kz(c1) = grad_kz(c1) + vol_face * grid % sz(s)

        vol_face = vof_norm(c1)
        grad_nx(c1) = grad_nx(c1) + vol_face * grid % sx(s)
        grad_ny(c1) = grad_ny(c1) + vol_face * grid % sy(s)
        grad_nz(c1) = grad_nz(c1) + vol_face * grid % sz(s)
      end if
    end do

    do c = 1, grid % n_cells
      grad_kx(c) = grad_kx(c) / grid % vol(c)
      grad_ky(c) = grad_ky(c) / grid % vol(c)
      grad_kz(c) = grad_kz(c) / grid % vol(c)

      grad_nx(c) = grad_nx(c) / grid % vol(c)
      grad_ny(c) = grad_ny(c) / grid % vol(c)
      grad_nz(c) = grad_nz(c) / grid % vol(c)
    end do

  end if

  ! Imposing contact angle at walls (before finding curvature):

  do s = 1, grid % n_faces
    c1 = grid % faces_c(1,s)
    c2 = grid % faces_c(2,s)
    fs = grid % f(s)

    if (c2 < 0) then
      if (Grid_Mod_Bnd_Cond_Type(grid,c2) .eq. WALL) then !contact angle
        norm_grad = norm2((/ grad_kx(c1), grad_ky(c1), grad_kz(c1)/))
        if (norm_grad > epsloc) then
          d_n = dot_product((/grid % dx(s), grid % dy(s), grid % dz(s)/)    &
                           ,(/grid % sx(s), grid % sy(s), grid % sz(s)/))   &
                           / grid % s(s) ** 2                               &
                           * (/grid % sx(s), grid % sy(s), grid % sz(s)/)

          grad_kx(c1) = grid % dx(s) / norm2(d_n)                      &
                                     * cos(vof % q(c2) * PI / 180.0)   &
                       + grad_kx(c1) * sin(vof % q(c2) * PI / 180.0) / norm_grad
          grad_ky(c1) = grid % dy(s) / norm2(d_n)                      &
                                     * cos(vof % q(c2) * PI / 180.0)   &
                       + grad_ky(c1) * sin(vof % q(c2) * PI / 180.0) / norm_grad
          grad_kz(c1) = grid % dz(s) / norm2(d_n)                      &
                                     * cos(vof % q(c2) * PI / 180.0)   &
                       + grad_kz(c1) * sin(vof % q(c2) * PI / 180.0) / norm_grad

        end if

        norm_grad = norm2((/ grad_nx(c1), grad_ny(c1), grad_nz(c1)/))

        if (norm_grad > epsloc) then
          d_n = dot_product((/grid % dx(s), grid % dy(s), grid % dz(s)/)    &
                           ,(/grid % sx(s), grid % sy(s), grid % sz(s)/))   &
                           / grid % s(s) ** 2                               &
                           * (/grid % sx(s), grid % sy(s), grid % sz(s)/)

          grad_nx(c1) = grid % dx(s) / norm2(d_n)                      &
                                     * cos(vof % q(c2) * PI / 180.0)   &
                       + grad_nx(c1) * sin(vof % q(c2) * PI / 180.0) / norm_grad
          grad_ny(c1) = grid % dy(s) / norm2(d_n)                      &
                                     * cos(vof % q(c2) * PI / 180.0)   &
                       + grad_ny(c1) * sin(vof % q(c2) * PI / 180.0) / norm_grad
          grad_nz(c1) = grid % dz(s) / norm2(d_n)                      &
                                     * cos(vof % q(c2) * PI / 180.0)   &
                       + grad_nz(c1) * sin(vof % q(c2) * PI / 180.0) / norm_grad

        end if

      end if

    end if
  end do

  call Grid_Mod_Exchange_Cells_Real(grid, grad_kx(-nb:nc))
  call Grid_Mod_Exchange_Cells_Real(grid, grad_ky(-nb:nc))
  call Grid_Mod_Exchange_Cells_Real(grid, grad_kz(-nb:nc))

  call Grid_Mod_Exchange_Cells_Real(grid, grad_nx(-nb:nc))
  call Grid_Mod_Exchange_Cells_Real(grid, grad_ny(-nb:nc))
  call Grid_Mod_Exchange_Cells_Real(grid, grad_nz(-nb:nc))

  !--------------------!
  !   Find Curvature   !
  !--------------------!

  mult % curv = 0.0

  do s = 1, grid % n_faces
    c1 = grid % faces_c(1,s)
    c2 = grid % faces_c(2,s)
    fs = grid % f(s)
    if (c2 > 0) then
      grad_face(1) = fs * grad_kx(c1) + (1.0 - fs) * grad_kx(c2)
      grad_face(2) = fs * grad_ky(c1) + (1.0 - fs) * grad_ky(c2)
      grad_face(3) = fs * grad_kz(c1) + (1.0 - fs) * grad_kz(c2)

      sxyz_mod = sqrt(grad_face(1) ** 2 + grad_face(2) ** 2 + grad_face(3) ** 2)

      if (sxyz_mod > epsloc) then
        dotprod = (grad_face(1) * grid % sx(s)  &
                 + grad_face(2) * grid % sy(s)  &
                 + grad_face(3) * grid % sz(s)) / sxyz_mod

        sxyz_control = norm2((/grad_kx(c1), grad_ky(c1), grad_kz(c1)/))

        if (sxyz_control > epsloc) then
          mult % curv(c1) = mult % curv(c1) + dotprod
        end if

        sxyz_control = norm2((/grad_kx(c2), grad_ky(c2), grad_kz(c2)/))

        if (sxyz_control > epsloc) then
          mult % curv(c2) = mult % curv(c2) - dotprod
        end if
      end if

    else
      grad_face(1) = grad_kx(c1)
      grad_face(2) = grad_ky(c1)
      grad_face(3) = grad_kz(c1)

      sxyz_mod = sqrt(grad_face(1) ** 2 + grad_face(2) ** 2 + grad_face(3) ** 2)

      if (sxyz_mod > epsloc) then
        dotprod = (grad_face(1) * grid % sx(s)  &
                 + grad_face(2) * grid % sy(s)  &
                 + grad_face(3) * grid % sz(s)) / sxyz_mod

        sxyz_control = norm2((/grad_kx(c1), grad_ky(c1), grad_kz(c1)/))

        if (sxyz_control > epsloc) then
          mult % curv(c1) = mult % curv(c1) + dotprod
        end if
      end if
    end if
  end do

  call Grid_Mod_Exchange_Cells_Real(grid, mult % curv)

  do c = 1, grid % n_cells
    mult % curv(c) = - mult % curv(c) / grid % vol(c)
  end do

  ! Smoothed normal
  if(.not.(mult % d_func) .and. mult % n_conv_norm > 0   &
     .and. mult % n_conv_norm <= mult % n_conv_curv) then
    vof % x = grad_nx
    vof % y = grad_ny
    vof % z = grad_nz
  end if

  end subroutine


submodule(chamber_interface) chamber_implementation
  !! Encapsulate the chamber components: propellant grain, combustion model, gas, & nozzle geometry
  use assertions_interface, only : assert, max_errmsg_len
  use gas_interface, only : gas_t
  use combustion_interface, only : combustion_t
  use nozzle_interface, only : nozzle_t
  use grain_interface, only : grain_t
  use kind_parameters, only : rkind
  implicit none

  real(rkind), parameter :: T_ambient=300._rkind, p_ambient=101325._rkind

contains

  module procedure define
    call this%grain_%define(input_file)
    call this%gas_%define(input_file)
    call this%combustion_%define(input_file)
    call this%nozzle_%define(input_file)
  end procedure

  module procedure gas
    gas = this%gas_
  end procedure

  module procedure volume
    volume = this%grain_%volume(burn_depth)
  end procedure

  module procedure temperature
    temperature = this%gas_%T(energy, mass)
  end procedure

  module procedure thrust
    thrust = this%nozzle_%thrust(gage_pressure=pressure-p_ambient)
  end procedure

  module procedure initial_volume
    real(rkind) initial_volume
    initial_volume = this%grain_%volume(burn_depth=0._rkind)
  end procedure

  module procedure burn_rate
    !! Result is the rate of surface-normal depth loss for the burning tablets
    use state_interface, only : state_t

    associate(burn_depth=>state%burn_depth())
      associate(e => state%energy(), m => state%mass(), V => this%grain_%volume(burn_depth))
        burn_rate = &
          merge(0._rkind, this%combustion_%burn_rate(this%gas_%p(energy=e, mass=m, volume=V)), this%grain_%burned_out(burn_depth))
      end associate
    end associate
  end procedure

  module procedure generate
    !! Result contains the burn rate, mass generation rate, and energy generation rate
    use state_interface, only : state_t
    use generation_rate_interface, only : generation_rate_t

    associate( &
      r => this%burn_rate(state), &
      A => this%grain_%surface_area(state%burn_depth()),  &
      rho => this%grain_%rho_solid() &
    )
      associate( &
        m_dot => rho*r*A, &
        T_flame => this%combustion_%T_flame() &
      )
        associate(h => this%gas_%c_p()*T_flame )
          rate = generation_rate_t( &
            burn_rate = r, &
            mass_generation_rate = m_dot, &
            enthalpy_generation_rate = m_dot*h &
          )
        end associate
      end associate
    end associate
  end procedure

  module procedure outflow
    use flow_rate_interface, only : flow_rate_t
    use state_interface, only : state_t
    real(rkind), parameter :: p2 = p_ambient, sqrt_2 = sqrt(2._rkind)

    associate(e => state%energy(), m => state%mass(), V => this%grain_%volume(state%burn_depth()), c_p => this%gas_%c_p())
      associate(T=>this%gas_%T(e,m), p =>this%gas_%p(e,m,V), ax=>this%nozzle_%area(), gx=>this%gas_%g(), rx=>this%gas_%R_gas())
        associate(p1=>p, p_crit=>(2./(gx+1.))**(gx/(gx-1.)))
          associate( &
            px => max(p1,p2), &
            tx => merge(T, T_ambient,      p1>p2), &
            p_ratio => merge(p1/p2, p2/p1, p1>p2), &
            d_sign_g=> merge(1., -1.,      p1>p2)  &
          )
            associate(hx=>c_p*tx, choked_flow => (1./p_ratio) < p_crit)
              if (choked_flow) then
                associate(c_star => sqrt((1./gx)*((gx+1.)/2.)**((gx+1.)/(gx-1.))*rx*tx))
                  associate(mdotos => px*ax/c_star)
                    rate = flow_rate_t(mass_flow_rate = mdotos, energy_flow_rate = mdotos*hx)
                  end associate
                end associate
              else
                associate(facx =>p_ratio**((gx-1.)/gx))
                  associate(term1 => sqrt(gx*rx*tx/facx), term2 => sqrt((facx-1.)/(gx-1.)))
                    associate(mdotos => d_sign_g*sqrt_2*px/p_ratio/rx/tx*facx*term1*term2*ax)
                      rate = flow_rate_t(mass_flow_rate = mdotos, energy_flow_rate = mdotos*hx)
                    end associate
                  end associate
                end associate
              end if
            end associate
          end associate
        end associate
      end associate
    end associate

  end procedure

  module procedure pressure
    pressure = this%gas_%p(energy, mass, volume)
  end procedure

end submodule chamber_implementation


      SUBROUTINE ANALYSE_PROPERTIES
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!! reads in block averages from disk
!!!! computes mean, standard deviation, standard error and
!!!! statistical inefficiency time
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      USE header_file
      IMPLICIT NONE

      REAL(kind = double), ALLOCATABLE, DIMENSION(:,:) :: A
      REAL(kind = double), DIMENSION(50,NUMPROPS) :: SIS
      REAL(kind = double), DIMENSION(NUMPROPS) :: SE,B, C, D, MEAN, FACT
      REAL(kind = double), DIMENSION(50) :: XST
      REAL(kind = double) :: RNT,S,AV,T,RNS,AVN,RMSD,CI,SI,YMX,SIMX
      INTEGER :: STATUS
      INTEGER :: I,J,K,NSUB,INT,NIT
      INTEGER :: KK,L,NMAX,NTOTAL,NTOT1
      INTEGER :: NTIM = 0

      CHARACTER(20), DIMENSION(NUMPROPS) :: PROPNAMES

      PROPNAMES(1) = 'kinetic Temp'
      PROPNAMES(2) = 'density'
      PROPNAMES(3) = 'pressure'
      PROPNAMES(4) = 'kinetic energy/N'
      PROPNAMES(5) = 'potential energy/N'
      PROPNAMES(6) = 'total energy/N'
      PROPNAMES(7) = 'PV/N: Kinetic'
      PROPNAMES(8) = 'PV/N: Potential'
      PROPNAMES(9) = 'PV/N: total'
      PROPNAMES(10) = 'PXX: potential '
      PROPNAMES(11) = 'PYY: potential '
      PROPNAMES(12) = 'PXY: potential '
      PROPNAMES(13) = 'PXX: kinetic '
      PROPNAMES(14) = 'PYY: kinetic '
      PROPNAMES(15) = 'PXY: kinetic '
      PROPNAMES(16) = 'PXX_TOT '
      PROPNAMES(17) = 'PYY_TOT '
      PROPNAMES(18) = 'PXY_TOT '
      PROPNAMES(19) = 'SHEAR RATE '
      PROPNAMES(20) = 'ZETA '
      PROPNAMES(21) = 'VOLUME '

      OPEN(12,FILE = 'results.txt',FORM = 'formatted',STATUS = 'unknown')

!!!!  read binary file of data cccccccccccccccc

      REWIND(55)

      readloop: DO
        READ(55,IOSTAT = status) ITIME,BLOCKAVG
        IF(status /= 0) EXIT
        NTIM = NTIM + 1
      END DO readloop

      readif: IF(status > 0) THEN ! a read error occured.
         WRITE(*,10) (NTIM + 1)
         10 FORMAT ('0', 'An error occurred reading line ', I7)
         STOP
      ELSE ! got to end of the file OK
         WRITE(*,20) NTIM
         20 FORMAT ('0', 'End of file reached. There were ', I7,&
                         ' values in the file.')
      END IF readif

      ALLOCATE(A(NTIM,NUMPROPS))

      REWIND(55)

      DO J = 1, NTIM
        READ(55) ITIME,BLOCKAVG
        DO I = 1, NUMPROPS
          A(J,I) = BLOCKAVG(I)
        END DO
      END DO

      RNT = NTIM

!!!  get averages

      DO I = 1, NUMPROPS
        S = 0.0d0
        DO J = 1, NTIM
          S = S + A(J,I)
        END DO
        B(I) = S/RNT
      END DO

!!! get variances

      DO I = 1, NUMPROPS
        AV = B(I)
        S = 0.0d0
        DO J = 1, NTIM
          S = S + (A(J,I) - AV)**2
        END DO
        C(I) = S/RNT
      END DO

      NSUB = 10
      INT = 0
      NIT = 0
      YMX = 0.0

!!! following code written donkeys years ago by David Brown in fortran 77.
!!! its not very structured so needs an overall at some stage

  500 CONTINUE
      NSUB = NSUB + 10*(1 + (NSUB/100))
      RNS = NSUB
      RNS = 1.0/RNS
      NMAX = NTIM/NSUB
      NIT = NIT + 1
      IF(NMAX < 5)  GOTO 501
      IF(NIT  > 50) GOTO 501
      INT = INT + 1
      XST(INT) = NSUB
      NTOTAL = NMAX*NSUB
      NTOT1 = NTOTAL + 1
      RNT = NTOTAL
      DO 502 J = 1,NUMPROPS
        AVN = 0.0d0
        IF(NTOTAL == NTIM) GOTO 503
        DO 504 I = NTOT1,NTIM
          AVN = AVN + A(I,J)
  504  CONTINUE
  503 CONTINUE
      MEAN(J) = (NTIM*B(J) - AVN)/RNT
  502 CONTINUE
      DO 509 J = 1,NUMPROPS
        I = 0
        T = 0.0d0
        DO 510 KK = 1,NMAX
          S = 0.0d0
          DO 511 l = 1,NSUB
            I = I + 1
            S = S + A(I,J)
  511     CONTINUE
        S = S*RNS
        T = T + (S - MEAN(J))**2
  510 CONTINUE
      D(J) = T/DBLE(NMAX)
  509 CONTINUE

      DO I = 1,NUMPROPS
        RMSD = SQRT(D(I))
        CI = C(I)
        IF(C(I) == 0.0d0) CI = 1.0d0
        SI = NSUB*D(I)/CI
        SIS(INT,I) = SI
        YMX = MAX(YMX,SI)
!        WRITE(12,601) PROPNAMES(I),MEAN(I),D(I),RMSD,SI
  601 format(a20,3x,4(e13.6,2x))
      END DO

      GOTO 500

  501 CONTINUE

      WRITE(12,698)
  698 format(///,'property',14x,'average',5x,'stand.error',&
     & 7x,'rmsd',8x,'stat.ineff.')
      WRITE(12,699)
  699 format('--------',14x,'-------',5x,'-----------',&
     & 7x,'----',8x,'-----------')
      WRITE(12,*)

      DO I = 1,NUMPROPS
        SIMX = 0.0d0
        DO J = 1,INT
          SIMX = MAX(SIMX,SIS(J,I))
        END DO
        SE(I) = SQRT(SIMX*C(I)/NTIM)
        RMSD = SQRT(C(I))
        WRITE(12,702) PROPNAMES(I),B(I),SE(I),RMSD,SIMX
      END DO
 702  FORMAT(a20,2x,4(e13.6,2x))

!!! write out some data in new file for use in perl scripts

      OPEN(22,FILE = 'Tabulated_results.txt')

      WRITE(22,*) B(19),',',SE(19)  !SHEAR RATE
      WRITE(22,*) B(1),',',SE(1)  !temperature
      WRITE(22,*) B(2),',',SE(2)  !density
      WRITE(22,*) B(21),',',SE(21)  !VOLUME
      WRITE(22,*) B(3),',',SE(3)  !pressure
      WRITE(22,*) B(6),',',SE(6)  !ETOT per particle
      WRITE(22,*) B(9),',',SE(9)  !PV per particle
      WRITE(22,*) B(16),',',SE(16)  !PXX
      WRITE(22,*) B(17),',',SE(17)  !PYY
      WRITE(22,*) B(18),',',SE(18)  !PXY
      WRITE(22,*) B(20),',',SE(20)  !ZETA

      CLOSE(22)

      END SUBROUTINE