C           SUBROUTINE INST2
      SUBROUTINE INST2
      REAL MFSTOP
      LOGICAL PREVER
      COMMON /SNTCP/G,AJ,PRPC,ICASE,PREVER,MFSTOP,JUMP,LOPIN,ISCASE,
     1KN,GAMF,IP,SCRIT,PTRN,ISECT,KSTG,WTOL,RHOTOL,PRTOL,TRLOOP,LSTG,
     2LBRC,IBRC,ICHOKE,ISORR,CHOKE,PT0PS1(6,8),PTRS2(6,8),TRDIAG,SC,RC,
     3DELPR,PASS,IPC,LOPC,ISS
C
      COMMON/GEBE/DRBARR,DRBARS,E1,E2,E3,E4,E5,E6,HBRRH,HBRSH,IAFE
     1,IALF,IBT2,ICPR,ICPS,ISR2,ISTR,ISTS,L,R1,R3,R4,R5,
     2TALF,WGT0(8),WT(7),HBARS,HBARR,I
C
      COMMON /SINIT/H1(6,8),H2(6,8),DP0(6,8),DP1(6,8),DP1A(6,8),DP2(6,8)
     1,DP2A(6,8),CSALF1(6,8),ALF1(6,8),CSBET2(6,8),BET2(6,8),RADSD(6,8),
     2RADRD(6,8),ANN1(6,8),ANN2(6,8),ANN2A(6,8),ANN1A(6,8),U1A(6,8),
     3U2(6,8),ANN0(6,8),PT0(6,8),TT0(6,8),ALPHA0(6,8),PTP(6,8)
C
      COMMON /SINPUT/
     1PTPS,PTIN,TTIN,WAIR,FAIR,DELC,DELL,DELA,AACS,VCTD,STG,SECT,EXPN,
     2EXPP,EXPRE,RG,RPM,PAF,SLI,STGCH,ENDJOB,XNAME(20),TITLE(20),
     3PCNH(6),GAM(6,8),DR(6,8),DT(6,8),RWG(6,8),ALPHAS(6,8),ALPHA1(6,8),
     4ETARS(6,8),ETAS(6,8),CFS(6,8),ANDO(6,8),BETA1(6,8),BETA2(6,8),ETAR
     5R(6,8),ETAR(6,8),CFR(6,8),TFR(6,8),ANDOR(6,8),OMEGAS(6,8),AS0(6,8)
     6,ASMP0(6,8),ACMN0(6,8),A1(6,8),A2(6,8),A3(6,8),A4(6,8),A5(6,8),A6(
     76,8),OMEGAR(6,8),BSIA(6,8),BSMPIA(6,8),BCMNIA(6,8),B1(6,8),B2(6,8)
     8,B3(6,8),B4(6,8),B5(6,8),B6(6,8),SESTHI(8),RERTHI(8)
     9,fairx(5,8),wairx(5,8),rg1(8),rg1a(8),rg2(8),rg2a(8)
C
      REAL M0
      COMMON /SSTA01/CP0(8),w0(6),               PS0(6,8),V0(6,8),TS0(6,
     18),VU0(6,8),VZ0(6,8),RHOS0(6,8),PS1(6,8),WGT1(8),TA1(8),WG1(6,8),
     2            DPDR1(6,8),SI(6,8),  CP1(8),PHI1(6,8),TS1(6,8),V1(6,8)
     3,RHOS1(6,8),ALF1E(6,8),VU1(6,8),VZ1(6,8),M0(6,8)
C
      REAL MR1A
      COMMON /SSTA1A/VU1A(6,8),WG1A(6,8),WGT1A(8),VZ1A(6,8),  CP1A(8),
     1PS1A(6,8),RU1A(6,8),R1A(6,8),BET1A(6,8),RI(6,8),TTR1A(6,8),PTR1A(6
     2,8),MR1A(6,8)
C
      COMMON /SSTA2/V2(6,8),TTR2(6,8),PTR2(6,8),WG2(6,8),WGT2(8),TA2(8),
     1           PS2(6,8),PHI2(6,8)
C
      REAL MR2,M2     ,MF2
      COMMON /SFLOW2/TS2(6,8),CP2(8),R2(6,8),RHOS2(6,8),BET2E(6,8),RU2(6
     1,8),VU2(6,8),DPDR2(6,8),VZ2(6,8),MR2(6,8),MF2(6,8),M2(6,8)
C
      REAL M2A,MF2A
      COMMON /SSTA2A/WG2A(6,8),WGT2A(8),VU2A(6,8),VZ2A(6,8),PS2A(6,8),
     1ALF2A(6,8),TT2A(6,8),PT2A(6,8),TTBAR(8),PTBAR(8),STT0(8),SPT0(8),
     2M2A(6,8),MF2A(6,8),CP2A(8),V2A(6,8),TS2A(6,8),TAS(8),PAS(8),GAMS(8
     3),CPO(8),DELHVD(6,8)
C
      COMMON /SOVRAL/DELHT(6,8),DELHTI(6,8),DELHSI(6,8),DEHATI(6,8),
     1ETATT(6,8),ETATS(6,8),ETATAT(6,8),delhtu(6,8)
C
      COMMON /BDINST/
     1IFMI01(4),IFMI02(4),IFMI03(4),IFMI04(4),IFMI05(4),IFMI06(4),
     2IFMI07(4),IFMI08(4),IFMI09(4),IFMI10(4),IFMI11(4),IFMI12(4),
     3IFMI13(4),IFMI14(4),IFMI15(4),IFMI16(4),IFMI17(4),IFMI18(4),
     4IFMI19(4),IFMI20(4),IFMI21(4),IFMI22(4),IFMI23(4),IFMI24(4),
     5IFMI25(4),IFMI26(4),IFMI27(4),IFMI28(4),IFMI29(4),IFMI30(4),
     6IFMI31(4),IFMI32(4),IFMI33(4),IFMI34(4),IFMI35(4),IFMI36(4),
     7IFMI37(4),IFMI38(4),IFMI39(4),IFMI40(4),IFMI41(4),IFMI42(4),
     8IFMI43(4),IFMI44(4),IFMI45(4),IFMI46(4),IFMI47(4),IFMI48(4),
     9IFMI49(4),IFMI50(4),IFMI51(4),IFMI52(4),IFMI53(4),IFMI54(4),
     1IFMI55(4),IFMI56(4),IFMI57(4),IFMI58(4),IFMI59(4),IFMI60(4),
     2IFMI61(4)
C
      COMMON /C1FIT1/ STDP0(7),STTT0(7),STPT0(7),STALF(7)
     1,STSI(7),STV0(7),STVU0(7),STVZ0(7),STTS0(7),
     2STPS0(7),STDEN0(7),STM0(7),STDP1(7),STTT1(7),
     3STALFE(7),STDELA(7),STV1(7),STVU1(7),STVZ1(7),
     4STTS1(7),STPS1(7),STDEN1(7),STM1(7),ZWIINC(7),
     5CPS(7),STDP1A(7),STTTR1(7),STPTR1(7),STBET1(7),
     6STRI(7),STR1A(7),STRU1A(7),STMR1A(7),STU1A(7),
     7STDP2(7),STBET2(7),SDBETA(7),SR2(7),SRU2(7),
     8SMR2(7),SU2(7),RX(7),STDELH(7),STPSI(7),
     9SETATT(7),SETATS(7),SETAAT(7),RZWINC(7),CPR(7),
     1STDP2A(7),STPT2(7),STTT2(7),STV2(7),STVU2(7),
     2STALF2(7),STMF2(7),STVZ2(7),STTS2(7),STPS2(7),
     3STDEN2(7),STM2(7),LJ,JJ,K
      COMMON /C2FIT1/  DBARS(7),FTANS(7),FAXS(7),DBARR(7),
     1FTANR(7),FAXR(7)
      COMMON RES(8),DALF(6),DSTS(6),DALFE(6),DCPS(6),DSTR(6),
     *DBT2(6),DCPR(6),DSR2(6)
      COMMON/TPT1/PT1(6),TT1(6,8)
      COMMON/DESOPT/RVU1(6,8),RVU2(6,8),WG,EPR
      dimension tangms(6,8),tangmr(6,8),tangm1(6,8),tangm2(6,8),tang0(6)
      common/slope/tangms,tangmr,tangm1,tangm2,tang0,iar,icyl
C
      DIMENSION IFMTA(4),IFMI1(4,61),Y(7,61)
      dimension slopd0(6),slopd1(6,8),slopd2(6,8)
      EQUIVALENCE (IFMI1(1,1),IFMI01(1)),(Y(1,1),STDP0(1))
      COMMON /DATTRF/ HP1, TT123(48), PT123(48), WG123(48), ETAS123(48),
     *                ETAR123(48), KS1

C
C
      DATA DOR/57.29578/
C
      LJ=1
      kj=1
      if (isect.eq.1) kj=3
      IF(ISECT.EQ.2) GO TO 20
      IF(ISECT.EQ.3) GO TO 20
c      if(isect.eq.1) go to 30
      JJ=7
      GO TO 40
20    JJ=5
c      go to 40
c30    jj=3
40    CONTINUE
      IF(ISECT.EQ.6) GO TO 50
      CALL FIT1
10    CONTINUE
      CALL FIT2
      IT=ISECT-2*(ISECT/2)
C     IF(IT)60,60,62
C     replaced by ...............
      IF(IT.LE.0) THEN
C60    GO TO(70,9,8,8,50,9,50),L
        GO TO(70,9,8,8,50,9,50),L
      ELSE
C62    GO TO(70,83,82,9,63,8,65),L
        GO TO(70,83,82,9,63,8,65),L
      ENDIF
C63    IF(ISECT-1)84,84,50
C     replaced by ........
63    IF(ISECT.LE.1)  THEN
        GO TO 84
      ELSE
        GO TO 50
      ENDIF
C65    IF(ISECT-1)75,50,50
C     replaced by ........
65    IF(ISECT.LT.1)  THEN
        GO TO 75
      ELSE
        GO TO 50
      ENDIF
C        CALCULATE   TIP   VALUES
70    I=ISECT
c     if(isect.eq.1) go to 43
      IF(ISECT.EQ.2) GO TO 45
      IF(ISECT.EQ.3) GO TO 45
      L=7
      GO TO 46
c3    l=3
c     go to 46
45    L=5
46    CONTINUE
      STDP0(L)=DT(1,K)
      R1=DP0(I,K)/DT(1,K)
      STDP1(L)=DT(2,K)
      R2(1,1)=DP1(I,K)/DT(2,K)
      STDP1A(L)=DT(3,K)
      R3=DP1A(I,K)/DT(3,K)
      STDP2(L)=DT(4,K)
      R4=DP2(I,K)/DT(4,K)
      TALF=SIN(ALF1(I,K))*R3/COS(ALF1(I,K))
      STDP2A(L)=DT(5,K)
      R5=DP2A(I,K)/DT(5,K)
      L1=L-3
      IF(ISECT.EQ.4)L1=3
      L2=L-2
      L3=L-1
      GO TO 10
50    IF(ISECT.EQ.6)L=7
      PIO4= 45./DOR
      FAXDHS= PIO4*(STPS0(1)+STPS1(1))*DBARS(1)*(STDP1(1)-STDP0(1))
      FAXDTS=-PIO4*(STPS0(L)+STPS1(L))*DBARS(L)*(STDP1(L)-STDP0(L))
      FAXDHR= PIO4*(STPS1(1)+STPS2(1))*DBARR(1)*(STDP2(1)-STDP1A(1))
      FAXDTR=-PIO4*(STPS1(L)+STPS2(L))*DBARR(L)*(STDP2(L)-STDP1A(L))
      IF(ISECT.EQ.3) GO TO 8
      IF(ISECT.EQ.5) GO TO 8
      IF(ISECT.EQ.1) GO TO 75
      I=ISECT/2
C     IF(ISECT-4)52,52,53
C     replaced by ........
      IF(ISECT.LE.4) THEN
        GO TO 52
      ELSE
        GO TO 53
      ENDIF
52    L=I+2
      GO TO 54
53    L=I+1
54    CONTINUE
      STDP0(L)=(DR(1,K)+DT(1,K))/2.
      R1=DP0(I,K)/STDP0(L)
      STDP1(L)=(DR(2,K)+DT(2,K))/2.
      R2(1,1)=DP1(I,K)/STDP1(L)
      STDP1A(L)=(DR(3,K)+DT(3,K))/2.
      R3=DP1A(I,K)/STDP1A(L)
      STDP2(L)=(DR(4,K)+DT(4,K))/2.
      R4=DP2(I,K)/STDP2(L)
      STDP2A(L)=(DR(5,K)+DT(5,K))/2.
      R5=DP2A(I,K)/((DR(5,K)+DT(5,K))/2.)
      GO TO 10
75    I=1
      L=3
      PH=.3
80    STDP0(L)=PH*(DT(1,K)-DR(1,K))+DR(1,K)
      R1=DP0(I,K)/STDP0(L)
      STDP1(L)=PH*(DT(2,K)-DR(2,K))+DR(2,K)
      R2(1,1)=DP1(I,K)/STDP1(L)
      STDP1A(L)=PH*(DT(3,K)-DR(3,K))+DR(3,K)
      R3=DP1A(I,K)/STDP1A(L)
      STDP2(L)=PH*(DT(4,K)-DR(4,K))+DR(4,K)
      R4=DP2(I,K)/STDP2(L)
      TALF=SIN(ALF1(I,K))*R3/COS(ALF1(I,K))
      STDP2A(L)=PH*(DT(5,K)-DR(5,K))+DR(5,K)
      R5=DP2A(I,K)/(PH*(DT(5,K)-DR(5,K))+DR(5,K))
      GO TO 10
82    L=2
      PH=.1
      GO TO 80
83    L=5
      PH=.7
      GO TO 80
84    L=6
      PH=.9
      GO TO 80
8     CONTINUE
      FTANTS=0.
      FAXTS=0.
      FTANTR=0.
      FAXTR=0.
      DO 121 L=LJ,JJ
      IF(L.EQ.1) GO TO 121
      DER=(DBARS(L)-DBARS(L-1))/4.
      FTANTS=FTANTS+(FTANS(L)+FTANS(L-1))*DER
      FAXTS= FAXTS+(FAXS(L)+FAXS(L-1))*DER
      DER=(DBARR(L)-DBARR(L-1))/4.
      FTANTR= FTANTR+(FTANR(L)+FTANR(L-1))*DER
      FAXTR= FAXTR+(FAXR(L)+FAXR(L-1))*DER
121   CONTINUE
      IF(ISECT.NE.6) GO TO 1211
      DH= HBARS/(DBARS(7)-DBARS(1))/2.
      FTANTS= FTANTS*DH
      FAXTS= FAXTS*DH
      DH= HBARR/(DBARR(7)-DBARR(1))/2.
      FTANTR= FTANTR*DH
      FAXTR= FAXTR*DH
1211  CONTINUE
      do 210 iw=1,isect
      slopd1(iw,k)=atan(tangm1(iw,k))*dor
      slopd2(iw,k)=atan(tangm2(iw,k))*dor
      if (k.eq.1) slopd0(iw)=atan(tang0(iw))*dor
  210 continue
      WRITE(16,1000) XNAME,TITLE,ICASE,ISCASE
1000  FORMAT(1H1,20X,29H     TURBINE COMPUTER PROGRAM/
     16X,20A4/6X,20A4/30X,5HCASE ,I3,1H.,I3/24X,
     223HINTER-STAGE PERFORMANCE/ )
      WRITE(16,1001) K
1001  FORMAT(5X,5HSTA 0,2X,12HSTATOR INLET,10X,
     15HSTAGE,I3,1H. )
      WRITE(16,301) (Y(KW,1),KW=lj,jj,kj)
      if (k.eq.1) write(16,1301) (slopd0(kw),kw=1,isect)
      if (k.gt.1) write(16,1301) (slopd2(kw,k-1),kw=1,isect)
      if (k.eq.1) write(16,1302) (w0(kw),kw=1,isect)
      if (k.gt.1) write(16,1302) (wg2a(kw,k-1),kw=1,isect)
      WRITE(16,302) (Y(KW,2),KW=lj,jj,kj)
      WRITE(16,303) (Y(KW,3),KW=lj,jj,kj)
      WRITE(16,304) (Y(KW,4),KW=lj,jj,kj)
      WRITE(16,305) (Y(KW,5),KW=lj,jj,kj)
      WRITE(16,306) (Y(KW,6),KW=lj,jj,kj)
      WRITE(16,307) (Y(KW,7),KW=lj,jj,kj)
      WRITE(16,308) (Y(KW,8),KW=lj,jj,kj)
      WRITE(16,309) (Y(KW,9),KW=lj,jj,kj)
      WRITE(16,310) (Y(KW,10),KW=lj,jj,kj)
      WRITE(16,311) (Y(KW,11),KW=lj,jj,kj)
      WRITE(16,312) (Y(KW,12),KW=lj,jj,kj)
      WRITE(16,1010)
1010  FORMAT(/5X,5HSTA 1,2X,11HSTATOR EXIT )
      WRITE(16,313) (Y(KW,13),KW=lj,jj,kj)
      write(16,1313) (slopd1(kw,k),kw=1,isect)
      write(16,1314) (wg1(kw,k),kw=1,isect)
      WRITE(16,314) (Y(KW,14),KW=lj,jj,kj)
      WRITE(16,315) (Y(KW,15),KW=lj,jj,kj)
      WRITE(16,316) (Y(KW,16),KW=lj,jj,kj)
      WRITE(16,317) (Y(KW,17),KW=lj,jj,kj)
      WRITE(16,318) (Y(KW,18),KW=lj,jj,kj)
      WRITE(16,319) (Y(KW,19),KW=lj,jj,kj)
      WRITE(16,320) (Y(KW,20),KW=lj,jj,kj)
      WRITE(16,321) (Y(KW,21),KW=lj,jj,kj)
      WRITE(16,322) (Y(KW,22),KW=lj,jj,kj)
      WRITE(16,323) (Y(KW,23),KW=lj,jj,kj)
      WRITE(16,324) (Y(KW,24),KW=lj,jj,kj)
      WRITE(16,325) (Y(KW,25),KW=lj,jj,kj)
      WRITE(16,2000)
2000  FORMAT(/12X,13HSTATOR FORCES )
      WRITE(16,2005) (DBARS(I),I=lj,jj,kj)
2005  FORMAT(1X,7HAVG DIA,7F9.3)
      WRITE(16,2006) (FTANS(I),I=lj,jj,kj)
2006  FORMAT(1X,7HFTAN/IN,7F9.1)
      WRITE(16,2007) FTANTS
2007  FORMAT(28X,7H  F TAN,F9.1)
      WRITE(16,2008) (FAXS(I),I=lj,jj,kj)
2008  FORMAT(1X,7H FAX/IN,7F9.1)
      WRITE(16,2009) FAXTS,FAXDHS,FAXDTS
2009  FORMAT(31X,4HF AX,F9.1/2X,6HF DRUM,F9.1,45X,F9.1)
      WRITE(16,1000)XNAME,TITLE,ICASE,ISCASE
      WRITE(16,1015) K
1015  FORMAT(4X,6HSTA 1A,2X,11HROTOR INLET,10X,5HSTAGE,I3 )
      WRITE(16,326) (Y(KW,26),KW=lj,jj,kj)
      write(16,1326)(slopd1(kw,k),kw=1,isect)
      write(16,1327)(wg1a(kw,k),kw=1,isect)
      WRITE(16,327) (Y(KW,27),KW=lj,jj,kj)
      WRITE(16,328) (Y(KW,28),KW=lj,jj,kj)
      WRITE(16,329) (Y(KW,29),KW=lj,jj,kj)
      WRITE(16,330) (Y(KW,30),KW=lj,jj,kj)
      WRITE(16,331) (Y(KW,31),KW=lj,jj,kj)
      WRITE(16,332) (Y(KW,32),KW=lj,jj,kj)
      WRITE(16,333) (Y(KW,33),KW=lj,jj,kj)
      WRITE(16,334) (Y(KW,34),KW=lj,jj,kj)
      WRITE(16,1020)
1020  FORMAT(/5X,5HSTA 2,2X,10HROTOR EXIT )
      WRITE(16,335) (Y(KW,35),KW=lj,jj,kj)
      write(16,1335)(slopd2(kw,k),kw=1,isect)
      write(16,1336)(wg2(kw,k),kw=1,isect)
      WRITE(16,336) (Y(KW,36),KW=lj,jj,kj)
      WRITE(16,337) (Y(KW,37),KW=lj,jj,kj)
      WRITE(16,338) (Y(KW,38),KW=lj,jj,kj)
      WRITE(16,339) (Y(KW,39),KW=lj,jj,kj)
      WRITE(16,340) (Y(KW,40),KW=lj,jj,kj)
      WRITE(16,341) (Y(KW,41),KW=lj,jj,kj)
      WRITE(16,342) (Y(KW,42),KW=lj,jj,kj)
      WRITE(16,343) (Y(KW,43),KW=lj,jj,kj)
      WRITE(16,344) (Y(KW,44),KW=lj,jj,kj)
      WRITE(16,345) (Y(KW,45),KW=lj,jj,kj)
      WRITE(16,346) (Y(KW,46),KW=lj,jj,kj)
      WRITE(16,347) (Y(KW,47),KW=lj,jj,kj)
      WRITE(16,348) (Y(KW,48),KW=lj,jj,kj)
      WRITE(16,349) (Y(KW,49),KW=lj,jj,kj)
      WRITE(16,2010)
2010  FORMAT(/12X,12HROTOR FORCES )
      WRITE(16,2005) (DBARR(I),I=lj,jj,kj)
      WRITE(16,2006) (FTANR(I),I=lj,jj,kj)
      WRITE(16,2007) FTANTR
      WRITE(16,2008) (FAXR(I),I=lj,jj,kj)
      WRITE(16,2009) FAXTR,FAXDHR,FAXDTR
      WRITE(16,2020)
2020  FORMAT(/4X,6HSTA 2A,2X,10HSTAGE EXIT)
      WRITE(16,350) (Y(KW,50),KW=lj,jj,kj)
      write(16,1350)(slopd2(kw,k),kw=1,isect)
      write(16,1351)(wg2a(kw,k),kw=1,isect)
c     print *,'  wg2a...  isect =',isect,' k=',k
      DO 555 I = 1,isect
         WG123(I) = WG2A(I,k)
555   CONTINUE
      WRITE(16,351) (Y(KW,51),KW=lj,jj,kj)

c     print *,'   lj,jj,kj  =',lj,jj,kj
      WRITE(16,352) (Y(KW,52),KW=lj,jj,kj)
C
C     save PT2A () values
      nii = 0
      DO 556 I = lJ,JJ,KJ
         nii = nii + 1
         KW = I
         PT123(NII) = Y(KW,51)
556   CONTINUE
C
C     save TT2A () values
      nii = 0
      DO 557 I = lJ,JJ,KJ
         nii = nii + 1
         KW = I
         TT123(NII) = Y(KW,52)
557   CONTINUE
      WRITE(16,353) (Y(KW,53),KW=lj,jj,kj)
      WRITE(16,354) (Y(KW,54),KW=lj,jj,kj)
      WRITE(16,355) (Y(KW,55),KW=lj,jj,kj)
      WRITE(16,356) (Y(KW,56),KW=lj,jj,kj)
      WRITE(16,357) (Y(KW,57),KW=lj,jj,kj)
      WRITE(16,358) (Y(KW,58),KW=lj,jj,kj)
      WRITE(16,359) (Y(KW,59),KW=lj,jj,kj)
      WRITE(16,360) (Y(KW,60),KW=lj,jj,kj)
      WRITE(16,361) (Y(KW,61),KW=lj,jj,kj)
  301 FORMAT (1X,7H DIAM 0,7F9.3)
 1301 format (1x,7hSLOPE 0,9x,6f9.2)
 1302 format (1x,7h   WG 0,9x,6f9.3)
  302 FORMAT (1X,7H   TT 0,7F9.1)
  303 FORMAT (1X,7H   PT 0,7F9.3)
  304 FORMAT (1X,7HALPHA 0,7F9.3)
  305 FORMAT (1X,7HI STA 0,7F9.3)
  306 FORMAT (1X,7H    V 0,7F9.3)
  307 FORMAT (1X,7H   VU 0,7F9.3)
  308 FORMAT (1X,7H   VZ 0,7F9.3)
  309 FORMAT (1X,7H   TS 0,7F9.1)
  310 FORMAT (1X,7H   PS 0,7F9.3)
  311 FORMAT (1X,7H DENS 0,7F9.5)
  312 FORMAT (1X,7H    M 0,7F9.5)
  313 FORMAT (1X,7H DIAM 1,7F9.3)
 1313 format (1x,7hSLOPE 1,9x,6f9.2)
 1314 format (1x,7h   WG 1,9x,6f9.3)
  314 FORMAT (1X,7H   TT 1,7F9.1)
  315 FORMAT (1X,7HALPHA 1,7F9.3)
  316 FORMAT (1X,7H  DEL A,7F9.3)
  317 FORMAT (1X,7H    V 1,7F9.3)
  318 FORMAT (1X,7H   VU 1,7F9.3)
  319 FORMAT (1X,7H   VZ 1,7F9.3)
  320 FORMAT (1X,7H   TS 1,7F9.1)
  321 FORMAT (1X,7H   PS 1,7F9.3)
  322 FORMAT (1X,7H DENS 1,7F9.5)
  323 FORMAT (1X,7H    M 1,7F9.5)
  324 FORMAT (1X,7HZWI INC,7F9.4)
  325 FORMAT (1X,7H  ETA S,7F9.4)
  326 FORMAT (1X,7HDIAM 1A,7F9.3)
 1326 format (1x,7hSLOP 1A,9x,6f9.2)
 1327 format (1x,7h  WG 1A,9x,6f9.3)
  327 FORMAT (1X,7H TTR 1A,7F9.1)
  328 FORMAT (1X,7H PTR 1A,7F9.3)
  329 FORMAT (1X,7HBETA 1A,7F9.3)
  330 FORMAT (1X,7HI ROTOR,7F9.3)
  331 FORMAT (1X,7H   R 1A,7F9.3)
  332 FORMAT (1X,7H  RU 1A,7F9.3)
  333 FORMAT (1X,7H  MR 1A,7F9.5)
  334 FORMAT (1X,7H   U 1A,7F9.3)
  335 FORMAT (1X,7H DIAM 2,7F9.3)
 1335 format (1x,7hSLOPE 2,9x,6f9.2)
 1336 format (1x,7h   WG 2,9x,6f9.3)
  336 FORMAT (1X,7H BETA 2,7F9.3)
  337 FORMAT (1X,7H  DBETA,7F9.3)
  338 FORMAT (1X,7H    R 2,7F9.3)
  339 FORMAT (1X,7H   RU 2,7F9.3)
  340 FORMAT (1X,7H   MR 2,7F9.5)
  341 FORMAT (1X,7H    U 2,7F9.3)
  342 FORMAT (1X,7H     RX,7F9.5)
  343 FORMAT (1X,7H  DEL H,7F9.3)
  344 FORMAT (1X,7H    PSI,7F9.5)
  345 FORMAT (1X,7H ETA TT,7F9.5)
  346 FORMAT (1X,7H ETA TS,7F9.5)
  347 FORMAT (1X,7H ETA AT,7F9.5)
  348 FORMAT (1X,7HZWI INC,7F9.4)
  349 FORMAT (1X,7H  ETA R,7F9.4)
  350 FORMAT (1X,7HDIAM 2A,7F9.3)
 1350 format (1x,7hSLOP 2A,9x,6f9.2)
 1351 format (1x,7h  WG 2A,9x,6f9.3)
  351 FORMAT (1X,7H  PT 2A,7F9.3)
  352 FORMAT (1X,7H  TT 2A,7F9.1)
  353 FORMAT (1X,7H   V 2A,7F9.3)
  354 FORMAT (1X,7H  VU 2A,7F9.3)
  355 FORMAT (1X,7HALPH 2A,7F9.3)
  356 FORMAT (1X,7H  MF 2A,7F9.5)
  357 FORMAT (1X,7H  VZ 2A,7F9.3)
  358 FORMAT (1X,7H  TS 2A,7F9.1)
  359 FORMAT (1X,7H  PS 2A,7F9.3)
  360 FORMAT (1X,7HDENS 2A,7F9.5)
  361 FORMAT (1X,7H   M 2A,7F9.5)
9     K=K+1
      RETURN
      END


C$Procedure SPKPV ( S/P Kernel, position and velocity )

      SUBROUTINE SPKPV ( HANDLE, DESCR, ET, REF, STATE, CENTER )

C$ Abstract
C
C     Return the state (position and velocity) of a target body
C     relative to some center of motion in a specified frame.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     SPK
C
C$ Keywords
C
C     EPHEMERIS
C
C$ Declarations

      IMPLICIT NONE

      INCLUDE               'zzctr.inc'

      INTEGER               HANDLE
      DOUBLE PRECISION      DESCR    ( 5 )
      DOUBLE PRECISION      ET
      CHARACTER*(*)         REF
      DOUBLE PRECISION      STATE    ( 6 )
      INTEGER               CENTER

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     HANDLE     I   File handle.
C     DESCR      I   Segment descriptor.
C     ET         I   Target epoch.
C     REF        I   Target reference frame.
C     STATE      O   Position, velocity.
C     CENTER     O   Center of state.
C
C$ Detailed_Input
C
C     HANDLE,
C     DESCR       are the file handle assigned to a SPK file, and the
C                 descriptor for a segment within the file. Together
C                 they determine the ephemeris data from which the
C                 state of the body is to be computed.
C
C     ET          is the epoch (ephemeris time) at which the state
C                 is to be computed.
C
C     REF         is the name of the reference frame to
C                 which the vectors returned by the routine should
C                 be rotated. This may be any frame supported by
C                 the SPICELIB subroutine FRMCHG.
C
C$ Detailed_Output
C
C     STATE       contains the position and velocity, at epoch ET,
C                 for whatever body is covered by the specified segment.
C                 STATE has six elements:  the first three contain the
C                 body's position; the last three contain the body's
C                 velocity.  These vectors are rotated into the
C                 specified reference frame, the origin of
C                 which is located at the center of motion for the
C                 body (see CENTER, below).  Units are always km and
C                 km/sec.
C
C     CENTER      is the integer ID code of the center of motion for
C                 the state.
C
C$ Parameters
C
C     NONE.
C
C$ Exceptions
C
C     1) If the requested reference frame is not supported by the
C        current version of CHGIRF, the error 'SPICE(SPKREFNOTSUPP)'
C        is signalled.
C
C$ Files
C
C     See argument HANDLE.
C
C$ Particulars
C
C     Once SPKPV was the most basic of the SPK readers, the reader upon
C     which SPKSSB, SPKAPP, and SPKEZ were built. However, its function
C     has now largely been replaced by SPKPVN. SPKPV should not normally
C     be called except by old software written before the release of
C     SPKPVN. This routine should be considered obsolete.
C
C
C$ Examples
C
C     In the following code fragment, an entire SPK file is searched
C     for segments containing a particular epoch. For each one found,
C     the body, center, segment identifier, and range at the epoch
C     are printed out.
C
C        CALL DAFOPR ( 'TEST.SPK', HANDLE )
C        CALL DAFBFS (             HANDLE )
C
C        CALL DAFFNA ( FOUND  )
C
C        DO WHILE ( FOUND )
C           CALL DAFGS ( DESCR )
C           CALL DAFUS ( DESCR, 2, 6, DC, IC )
C
C           IF ( DC(1) .LE. ET  .AND.  ET .LE. DC(2) ) THEN
C              CALL SPKPV ( HANDLE, DESCR, ET, 'J2000', STATE, CENTER )
C              CALL DAFGN ( IDENT )
C
C              WRITE (*,*)
C              WRITE (*,*) 'Body   = ', IC(1)
C              WRITE (*,*) 'Center = ', CENTER,
C              WRITE (*,*) 'ID     = ', IDENT
C              WRITE (*,*) 'Range  = ', VNORM ( STATE )
C           END IF
C
C           CALL DAFFNA ( FOUND )
C        END DO
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     NAIF Document 168.0, "S- and P- Kernel (SPK) Specification and
C     User's Guide"
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C     K.R. Gehringer  (JPL)
C     W.L. Taber      (JPL)
C     J.M. Lynch      (JPL)
C     B.V. Semenov    (KPL)
C     R.E. Thurman    (JPL)
C     I.M. Underwood  (JPL)
C
C$ Version
C
C-    SPICELIB Version 6.1.0, 06-DEC-2013 (BVS) (NJB)
C
C        Updated to save the input frame name and POOL state counter
C        and to do frame name-ID conversion only if the counter has
C        changed. In-line comment regarding frame change was edited.
C
C-    SPICELIB Version 6.0.0, 19-SEP-1995 (WLT)
C
C        The routine was updated to handle non-inertial frames.
C
C-    SPICELIB Version 5.0.0, 13-MAR-1995 (KRG)
C
C        The routine was updated to handle type 14.
C
C        A new exception, 3, was also added.
C
C-    SPICELIB Version 4.0.0, 04-NOV-1994 (WLT)
C
C        The routine was updated to handle type 15.
C
C-    SPICELIB Version 3.0.0, 04-AUG-1993 (NJB)
C
C        The routine was updated to handle types 08 and 09.
C
C-    SPICELIB Version 2.0.0, 01-APR-1992 (JML)
C
C        The routine was updated to handle type 05.
C
C-    SPICELIB Version 1.0.2, 18-JUL-1991 (NJB)
C
C        The description of the output STATE was expanded slightly.
C
C-    SPICELIB Version 1.0.1, 22-MAR-1990 (HAN)
C
C        Literature references added to the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) (RET)
C
C-&

C$ Index_Entries
C
C     position and velocity from ephemeris
C     spk file position and velocity
C
C-&

C$ Revisions
C
C-    SPICELIB Version 6.0.0, 6-OCT-1994 (WLT)
C
C        The routine was updated to handle non-inertial frames.
C
C-    SPICELIB Version 5.0.0, 13-MAR-1995 (KRG)
C
C        The routine was updated to handle type 14.
C
C        A new exception, 3, was also added.
C
C-    SPICELIB Version 4.0.0, 04-NOV-1994 (WLT)
C
C        The routine was updated to handle type 15.
C
C-    SPICELIB Version 3.0.0, 04-AUG-1993 (NJB)
C
C        The routine was updated to handle types 08 and 09.
C
C-    SPICELIB Version 2.0.0, 01-APR-1992 (JML)
C
C        The routine was updated to handle type 05.
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               RETURN

C
C     Local parameters.
C

C
C     Saved frame name length.
C
      INTEGER               FRNMLN
      PARAMETER           ( FRNMLN = 32 )

C
C     Some local space is needed in which to return records, and
C     into which to unpack the segment descriptor.
C
      INTEGER               IRF
      INTEGER               IRFREQ
      INTEGER               IC         (    6 )
      DOUBLE PRECISION      DC         (    2 )
      DOUBLE PRECISION      XFORM      ( 6, 6 )
      DOUBLE PRECISION      TSTATE     ( 6    )

C
C     Saved frame name/ID item declarations.
C
      INTEGER               SVCTR1 ( CTRSIZ )
      CHARACTER*(FRNMLN)    SVREF
      INTEGER               SVIRFR

      LOGICAL               FIRST

C
C     Saved frame name/ID items.
C
      SAVE                  SVCTR1
      SAVE                  SVREF
      SAVE                  SVIRFR

      SAVE                  FIRST

C
C     Initial values.
C
      DATA                  FIRST   / .TRUE. /

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'SPKPV' )
      END IF

C
C     Initialization.
C
      IF ( FIRST ) THEN

C
C        Initialize counter.
C
         CALL ZZCTRUIN( SVCTR1 )

         FIRST = .FALSE.

      END IF

      CALL DAFUS ( DESCR, 2, 6, DC, IC )

      CENTER = IC(2)
      IRF    = IC(3)

C
C     Rotate the raw state from its native frame to the one requested
C     by the user only if the two frames differ.
C
      CALL ZZNAMFRM ( SVCTR1, SVREF, SVIRFR, REF, IRFREQ )

      IF ( IRFREQ .EQ. 0 ) THEN

         CALL SETMSG ( 'No support for frame #.' )
         CALL ERRCH  ( '#', REF                  )
         CALL SIGERR ( 'SPICE(SPKREFNOTSUPP)'    )

      ELSE IF ( IRFREQ .NE. IRF ) THEN

         CALL SPKPVN ( HANDLE, DESCR,  ET, IRF, TSTATE, CENTER )
         CALL FRMCHG ( IRF,    IRFREQ, ET,              XFORM  )
         CALL MXVG   ( XFORM,  TSTATE,  6, 6,           STATE  )

      ELSE

         CALL SPKPVN ( HANDLE, DESCR, ET, IRF, STATE, CENTER )

      END IF

      CALL CHKOUT ( 'SPKPV' )
      RETURN
      END


#include "Definitions.INC"

!! ALL MODULES

module parblocklanmod
contains

  subroutine parblockconfigmult0_gather(wwin,cptr,sptr,inavector,outavector)
    use fileptrmod
    use r_parameters
    use sparse_parameters
    use ham_parameters
    use mpimod
    use walkmod
    use sparseptrmod
    use configptrmod
    use sparsemultmod
    use basissubmod
    use mpisubmod
    implicit none
    type(walktype),intent(in) :: wwin
    type(CONFIGPTR),intent(in) :: cptr
    type(SPARSEPTR),intent(in) :: sptr
    integer :: ii
    DATATYPE,intent(in) :: inavector(numr,wwin%botdfbasis:wwin%topdfbasis)
    DATATYPE,intent(out) :: outavector(numr,wwin%botdfbasis:wwin%topdfbasis)
    DATATYPE,allocatable :: intemp(:,:)
    DATATYPE :: outtemp(numr,wwin%botconfig:wwin%topconfig+1)   !! AUTOMATIC

    if (sparseconfigflag.eq.0) then
       OFLWR "error, must use sparse for parblockconfigmult"; CFLST
    endif

    allocate(intemp(numr,wwin%numconfig));    intemp(:,:)=0d0; outtemp=0

!! transform second to reduce communication?
!!   no, spin transformations done locally now.

    if (wwin%topdfbasis.ge.wwin%botdfbasis) then
       call basis_transformfrom_local(wwin,numr,inavector,&
            intemp(:,wwin%botconfig:wwin%topconfig))
    endif

    call mpiallgather_local(intemp,wwin%numconfig*numr,&
         wwin%nzconfsperproc(:)*numr,wwin%maxconfigsperproc*numr,&
         wwin%NZ_COMM,wwin%nzprocs,wwin%nzrank)

    if (wwin%topconfig.ge.wwin%botconfig) then
       call sparseconfigmult_byproc(1,nprocs,wwin,intemp,outtemp, cptr, sptr, &
            1,1,1,0,0d0,0,1,numr,0,-1)
       if (mshift.ne.0d0) then
          do ii=wwin%botconfig,wwin%topconfig
             outtemp(:,ii)=outtemp(:,ii)+ intemp(:,ii)*wwin%configmvals(ii)*mshift
          enddo
       endif
    endif

    if (wwin%topdfbasis.ge.wwin%botdfbasis) then
       call basis_transformto_local(wwin,numr,outtemp,outavector)
    endif

    deallocate(intemp)

  end subroutine parblockconfigmult0_gather

#ifdef MPIFLAG

  subroutine parblockconfigmult0_summa(wwin,cptr,sptr,inavector,outavector)
    use fileptrmod
    use r_parameters
    use sparse_parameters
    use ham_parameters
    use mpimod
    use walkmod
    use sparseptrmod
    use configptrmod
    use sparsemultmod
    use basissubmod
    use mpisubmod
    implicit none
    type(walktype),intent(in) :: wwin
    type(CONFIGPTR),intent(in) :: cptr
    type(SPARSEPTR),intent(in) :: sptr
    integer :: ii,iproc,iiproc
    DATATYPE,intent(in) :: inavector(numr,wwin%botdfbasis:wwin%topdfbasis)
    DATATYPE,intent(out) :: outavector(numr,wwin%botdfbasis:wwin%topdfbasis)
    DATATYPE :: intemp(numr,wwin%maxconfigsperproc),&
         outwork(numr,wwin%botconfig:wwin%topconfig+1),&
         outtemp(numr,wwin%botconfig:wwin%topconfig+1)  !! AUTOMATIC

    if (sparseconfigflag.eq.0) then
       OFLWR "error, must use sparse for parblockconfigmult"; CFLST
    endif

    outwork(:,:)=0d0; outtemp=0; intemp=0

    do iiproc=1,wwin%nzprocs

       iproc=wwin%nzproclist(iiproc)

!! transform second to reduce communication?
!!   no, spin transformations done locally now.

       if (wwin%alltopconfigs(iproc).ge.wwin%allbotconfigs(iproc)) then
          if (myrank.eq.iproc) then
             intemp=0d0
             if (wwin%topdfbasis.ge.wwin%botdfbasis) then
                call basis_transformfrom_local(wwin,numr,inavector,intemp)
             endif
          endif
          call mympibcast_local(intemp,iiproc,wwin%nzconfsperproc(iiproc)*numr,wwin%NZ_COMM)

          call sparseconfigmult_byproc(iproc,iproc,wwin,intemp,outtemp, cptr, sptr, &
               1,1,1,0,0d0,0,1,numr,0,-1)

          if (myrank.eq.iproc) then
             if (mshift.ne.0d0) then
                do ii=wwin%botconfig,wwin%topconfig
                   outtemp(:,ii)=outtemp(:,ii) + &
                        intemp(:,ii-wwin%botconfig+1)*wwin%configmvals(ii)*mshift
                enddo
             endif
          endif
          outwork(:,:)=outwork(:,:) + outtemp(:,:)
       endif
    enddo

    if (wwin%topdfbasis.ge.wwin%botdfbasis) then
       call basis_transformto_local(wwin,numr,outwork,outavector)
    endif

  end subroutine parblockconfigmult0_summa

  subroutine parblockconfigmult0_circ(wwin,cptr,sptr,inavector,outavector)
    use fileptrmod
    use r_parameters
    use sparse_parameters
    use ham_parameters
    use mpimod
    use walkmod
    use sparseptrmod
    use configptrmod
    use sparsemultmod
    use basissubmod
    use mpisubmod
    implicit none
    type(walktype),intent(in) :: wwin
    type(CONFIGPTR),intent(in) :: cptr
    type(SPARSEPTR),intent(in) :: sptr
    integer :: ii,iproc,prevproc,nextproc,deltaproc,iiproc
    DATATYPE,intent(in) :: inavector(numr,wwin%botdfbasis:wwin%topdfbasis)
    DATATYPE,intent(out) :: outavector(numr,wwin%botdfbasis:wwin%topdfbasis)
    DATATYPE :: workvector(numr,wwin%maxconfigsperproc), &
         workvector2(numr,wwin%maxconfigsperproc), &
         outwork(numr,wwin%botconfig:wwin%topconfig+1), &
         outtemp(numr,wwin%botconfig:wwin%topconfig+1)  !! AUTOMATIC

    if (sparseconfigflag.eq.0) then
       OFLWR "error, must use sparse for parblockconfigmult"; CFLST
    endif

!! doing circ mult slightly different than e.g. SINCDVR/coreproject.f90
!!     and ftcore.f90, holding hands in a circle, prevproc and nextproc,
!!     each chunk gets passed around the circle

    prevproc=mod(wwin%nzprocs+wwin%nzrank-2,wwin%nzprocs)+1
    nextproc=mod(wwin%nzrank,wwin%nzprocs)+1

    outwork(:,:)=0d0; outtemp=0; workvector=0; workvector2=0

    if (wwin%topdfbasis.ge.wwin%botdfbasis) then
       call basis_transformfrom_local(wwin,numr,inavector,workvector)
       if (mshift.ne.0d0) then
          do ii=wwin%botconfig,wwin%topconfig
             outwork(:,ii)=outwork(:,ii) + &
                  workvector(:,ii-wwin%botconfig+1)*wwin%configmvals(ii)*mshift
          enddo
       endif
    endif

    do deltaproc=0,wwin%nzprocs-1

!! PASSING BACKWARD (plus deltaproc)

       iiproc=mod(wwin%nzrank-1+deltaproc,wwin%nzprocs)+1
       iproc=wwin%nzproclist(iiproc)

       if (wwin%alltopconfigs(iproc).ge.wwin%allbotconfigs(iproc)) then
          call sparseconfigmult_byproc(iproc,iproc,wwin,workvector,outtemp, cptr, sptr, &
               1,1,1,0,0d0,0,1,numr,0,-1)

          outwork(:,:)=outwork(:,:) + outtemp(:,:)
       endif

!! PASSING BACKWARD
!! mympisendrecv(sendbuf,recvbuf,dest,source,...)

       call mympisendrecv_local(workvector,workvector2,prevproc,nextproc,deltaproc,&
            numr * wwin%maxconfigsperproc,wwin%NZ_COMM)
       workvector(:,:)=workvector2(:,:)

    enddo

    if (wwin%topdfbasis.ge.wwin%botdfbasis) then
       call basis_transformto_local(wwin,numr,outwork,outavector)
    endif

  end subroutine parblockconfigmult0_circ

#endif

  subroutine parblockconfigmult(inavector,outavector)
    use r_parameters
    use sparse_parameters
    use configmod
    use xxxmod
    use fileptrmod
    implicit none
    DATATYPE,intent(in) :: inavector(numr,dwwptr%botdfbasis:dwwptr%topdfbasis)
    DATATYPE,intent(out) :: outavector(numr,dwwptr%botdfbasis:dwwptr%topdfbasis)

#ifdef MPIFLAG
    select case (sparsesummaflag)
    case(0)
#endif
       call parblockconfigmult0_gather(dwwptr,yyy%cptr(0),yyy%sptrptr(0),inavector,outavector)
#ifdef MPIFLAG
    case(1)
       call parblockconfigmult0_summa(dwwptr,yyy%cptr(0),yyy%sptrptr(0),inavector,outavector)
    case(2)
       call parblockconfigmult0_circ(dwwptr,yyy%cptr(0),yyy%sptrptr(0),inavector,outavector)
    case default
       OFLWR "Error sparsesummaflag ", sparsesummaflag; CFLST
    end select
#endif

  end subroutine parblockconfigmult

end module parblocklanmod

module lanblockmod
contains

subroutine blocklanczos0( lanblocknum, numout, lansize,maxlansize,order,maxiter, &
     outvectors,outvectorlda, outvalues,inprintflag,guessflag,lancheckmod,lanthresh,&
     multsub,logpar,targetflag,etarget)
  use mpimod
  implicit none
  logical,intent(in) :: logpar
  integer,intent(in) :: lansize,maxlansize,maxiter,lanblocknum,inprintflag,order,&
       lancheckmod,outvectorlda,numout,targetflag,guessflag
  DATATYPE, intent(in) :: etarget
  DATAECS, intent(out) :: outvalues(numout)
  DATATYPE, intent(inout) :: outvectors(outvectorlda,numout)
  real*8, intent(in) :: lanthresh
#ifndef MPIFLAG
  integer,parameter :: MPI_COMM_WORLD = (-798)
#endif
  external :: multsub

  call blocklanczos0_local( lanblocknum, numout, lansize,maxlansize,order,maxiter, &
       outvectors,outvectorlda, outvalues,inprintflag,guessflag,lancheckmod,lanthresh,&
       multsub,logpar,targetflag,etarget,MPI_COMM_WORLD)

end subroutine blocklanczos0

!! guessflag=1  use outvectors for initial krylov vectors
!!          =2  do that and also follow, return eigvects with max overlap

subroutine blocklanczos0_local( lanblocknum, numout, lansize,maxlansize,order,maxiter, &
     outvectors,outvectorlda, outvalues,inprintflag,guessflag,lancheckmod,lanthresh,&
     multsub,logpar,targetflag,etarget,IN_COMM)
  use fileptrmod
  use mpisubmod
  use eigenmod
  implicit none
  logical,intent(in) :: logpar
  integer,intent(in) :: lansize,maxlansize,maxiter,lanblocknum,inprintflag,order,&
       lancheckmod,outvectorlda,numout,targetflag,guessflag,IN_COMM
  DATATYPE, intent(in) :: etarget
  DATAECS, intent(out) :: outvalues(numout)
  DATATYPE, intent(inout) :: outvectors(outvectorlda,numout)
  real*8, intent(in) :: lanthresh
  external :: multsub
  integer :: printflag, iorder,k,flag,j,id,nn,i,thislanblocknum, thisdim,thisout
  real*8 :: error(numout), stopsum,rsum,nextran
  DATATYPE :: alpha(lanblocknum,lanblocknum),beta(lanblocknum,lanblocknum), &
       nullvector1(100)=0, nullvector2(100)=0, lastvalue(numout), thisvalue(numout), &
       valdot(numout),normsq(numout),sqdot(numout)
!! made these allocatable to fix lawrencium segfault 04-15
  DATATYPE, allocatable :: lanham(:,:,:,:), laneigvects(:,:,:), templanham(:,:),&
       betas(:,:,:),betastr(:,:,:),       invector(:), multvectors(:,:), &
       lanvects(:,:,:), tempvectors(:,:),  lanmultvects(:,:,:), tempvectors2(:,:), &
       followvects(:,:), followlandots(:,:,:)
  DATAECS, allocatable :: laneigvals(:)

  if (numout.lt.lanblocknum) then
     OFLWR "numout >= lanblocknum please",numout,lanblocknum; CFLST
  endif
  if (numout.gt.order*lanblocknum) then
     OFLWR "numout gt order*lanblocknum is impossible.",numout,order,lanblocknum; CFLST
  endif

  allocate(&
       invector(maxlansize), multvectors(maxlansize,lanblocknum), &
       lanvects(maxlansize,lanblocknum,order), tempvectors(maxlansize,numout), &
       lanmultvects(maxlansize,lanblocknum,order), tempvectors2(maxlansize,numout))

  invector=0d0; multvectors=0d0; lanvects=0d0; tempvectors=0d0;
  lanmultvects=0d0; tempvectors2=0d0

  if (guessflag.eq.2) then
     allocate(followvects(maxlansize,numout),followlandots(numout,lanblocknum,order))
  else
     allocate(followvects(1,numout),followlandots(1,1,order))
  endif
  followvects=0; followlandots=0;

  allocate( &
       lanham(lanblocknum,order,lanblocknum,order),&
       laneigvects(lanblocknum,order,order*lanblocknum), &
       laneigvals(order*lanblocknum), &
       templanham(lanblocknum*order,lanblocknum*order))
  lanham=0d0; laneigvects=0d0; laneigvals=0d0; templanham=0d0

  printflag=inprintflag

  lastvalue(:)=1d10;  thisvalue(:)=1d9;   alpha=0; beta=0;

  call rand_init(1731.d0)

  if (guessflag==0) then
     outvectors=0.0d0
     do k=1,numout
        do i=1,lansize
           outvectors(i,k)=nextran() + (0d0,1d0) * nextran()
        enddo
     enddo
  endif

!! follow vectors
  if (guessflag.eq.2) then
     followvects(1:lansize,:) = outvectors(1:lansize,:)
  endif

  outvectors(lansize+1:,:)=0d0  ! why not

  flag=0
  do while (flag.ne.1)
     flag=0

     do j=1,numout
        if (lansize.eq.0) then
           call multsub(nullvector1(:),nullvector2(:))
           call multsub(nullvector1(:),nullvector2(:))
        else
           call multsub(outvectors(:,j),tempvectors(:,j))
           call multsub(tempvectors(:,j),tempvectors2(:,j))
        endif
     enddo

     error(:)=1000d0

     if (lansize.eq.0) then
        call vecnulldots(numout,normsq,logpar)
        call vecnulldots(numout,valdot,logpar)
        call vecnulldots(numout,sqdot,logpar)
     else
        call vechdots(outvectors(:,:),outvectors(:,:),lansize,outvectorlda,&
             outvectorlda,numout,normsq,logpar)
        call vechdots(outvectors(:,:),tempvectors(:,:),lansize,outvectorlda,&
             maxlansize,numout,valdot,logpar)
        call vechdots(outvectors(:,:),tempvectors2(:,:),lansize,outvectorlda,&
             maxlansize,numout,sqdot,logpar)
     endif

     do j=1,numout
        error(j)=abs(&
             valdot(j)**2 / normsq(j)**2 - &
             sqdot(j)/normsq(j))
     enddo
     if (printflag.ne.0) then
        OFL; write(mpifileptr,'(A10,1000E8.1)') " FIRST ERRORS ", error(1:numout); CFL
     endif

     stopsum=0d0
     do nn=1,numout
        if (error(nn).gt.stopsum) then
           stopsum=error(nn)
        endif
     enddo
     if (stopsum.lt.lanthresh) then
        OFLWR "Vectors converged on read",stopsum,lanthresh; CFL
        flag=1
     else
        if (printflag.ne.0) then
           OFLWR "MAX ERROR : ", stopsum, lanthresh; CFL
        endif
     endif

     if (lansize.gt.0) then
        lanvects(1:lansize,:,1)=outvectors(1:lansize,1:lanblocknum)
     endif

     if (guessflag.eq.2) then
        if (lansize.eq.0) then
           call allnulldots(lanblocknum,lanblocknum,followlandots(:,:,1),logpar)
        else
           call allhdots(followvects(:,:),lanvects(:,:,1),lansize,&
                maxlansize,numout,lanblocknum,followlandots(:,:,1),logpar)
        endif
     endif

     lanham(:,:,:,:)=0.0d0
     do i=1,lanblocknum
        if (lansize.eq.0) then
           call nullgramschmidt_fast(i-1, logpar)
        else
           call myhgramschmidt_fast(lansize, i-1, maxlansize, &
                lanvects(:,:,1),lanvects(:,i,1),logpar)
        endif
     enddo
     do j=1,lanblocknum
        if (lansize.eq.0) then
           call multsub(nullvector1(:),nullvector2(:))
        else
           call multsub(lanvects(:,j,1),multvectors(:,j))
        endif
     enddo

     lanmultvects(:,:,1)=multvectors(:,:)

     if (lansize.eq.0) then
        call allnulldots(lanblocknum,lanblocknum,alpha,logpar)
     else
        call allhdots(lanvects(:,:,1),multvectors(:,:),lansize,&
             maxlansize,lanblocknum,lanblocknum,alpha,logpar)
     endif

     lanham(:,1,:,1)= alpha(:,:)

     if (printflag.ne.0) then
        OFLWR "FIRST ALPHA ", alpha(1,1); CFL
     endif

     iorder=1
     do while ( flag==0 )

        iorder=iorder+1
        if (iorder.eq.order) then
           flag=2
        endif
! each loop: multvector is h onto previous normalized vector

        if (lansize.gt.0) then
           lanvects(1:lansize,:,iorder)=multvectors(1:lansize,:)
        endif

        thislanblocknum=lanblocknum
        if (iorder*lanblocknum.ge.maxiter) then
           OFLWR "Max iters ",maxiter," reached, setting converged flag to 2"; CFL
           flag=2
           thislanblocknum=maxiter-(iorder-1)*lanblocknum
        endif

        do i=1,thislanblocknum
           if (lansize.eq.0) then
              call nullgramschmidt_fast((iorder-1)*lanblocknum+i-1,logpar)
           else
              call myhgramschmidt_fast(lansize, (iorder-1)*lanblocknum+i-1, &
                   maxlansize, lanvects,lanvects(:,i,iorder),logpar)
           endif
        enddo

        if (guessflag.eq.2) then
           if (lansize.eq.0) then
              call allnulldots(lanblocknum,lanblocknum,followlandots(:,:,iorder),logpar)
           else
              call allhdots(followvects(:,:),lanvects(:,:,iorder),lansize,&
                   maxlansize,numout,lanblocknum,followlandots(:,:,iorder),logpar)
           endif
        endif

        multvectors(:,:)=0d0
        if (lansize.eq.0) then
           do j=1,thislanblocknum
              call multsub(nullvector2(:),nullvector1(:))
           enddo
        else
           do j=1,thislanblocknum
              call multsub(lanvects(:,j,iorder),multvectors(:,j))
           enddo
        endif
        lanmultvects(:,:,iorder)=multvectors(:,:)

        if (lansize.eq.0) then
           call allnulldots(lanblocknum,lanblocknum,alpha,logpar)
        else
           call allhdots(lanvects(:,:,iorder),multvectors(:,:),lansize,&
                maxlansize,lanblocknum,lanblocknum,alpha,logpar)
        endif
        lanham(:,iorder,:,iorder)=alpha(:,:)

        allocate(betas(lanblocknum,iorder-1,lanblocknum), &
             betastr(lanblocknum,lanblocknum,iorder-1))

        if (lansize.eq.0) then
           call allnulldots(lanblocknum*(iorder-1),lanblocknum,betas(:,:,:),logpar)
           call allnulldots(lanblocknum,lanblocknum*(iorder-1),betastr(:,:,:),logpar)
        else
           call allhdots(lanvects(:,:,:),lanmultvects(:,:,iorder),lansize,maxlansize,&
                lanblocknum*(iorder-1),lanblocknum,betas(:,:,:),logpar)
           call allhdots(lanvects(:,:,iorder),lanmultvects(:,:,:),lansize,maxlansize,&
                lanblocknum,lanblocknum*(iorder-1),betastr(:,:,:),logpar)
        endif

!!$        call allhdots(lanvects(:,:,iorder),lanmultvects(:,:,iorder-1),lansize,&
!!$            maxlansize,lanblocknum,lanblocknum,betastr(:,:,iorder-1),logpar)

        do i=1,iorder-1
           lanham(:,i,:,iorder)=betas(:,i,:)
        enddo
        do i=1,iorder-1                !!$  not needed on paper (arnoldi), just iorder-1
!!$        do i=iorder-1,iorder-1
           lanham(:,iorder,:,i)=betastr(:,:,i)
        enddo
        deallocate(betas,betastr)

!!! flag.ne.0 for maxiter, iorder
        if (mod(iorder,lancheckmod).eq.0.or.flag.ne.0) then

           templanham(:,:)=0d0
           templanham(1:lanblocknum*iorder,1:lanblocknum*iorder)=&
                RESHAPE(lanham(:,1:iorder,:,1:iorder),&
                (/lanblocknum*iorder,lanblocknum*iorder/))
           thisdim=min(maxiter,iorder*lanblocknum)
           call CONFIGEIG(templanham,thisdim,order*lanblocknum,laneigvects,laneigvals)
           if (targetflag.ne.0) then
              call mysort2(laneigvects,laneigvals,thisdim,order*lanblocknum)
           endif

           if (guessflag.eq.2) then
              call followsort(thisdim,followlandots)
           endif

           thisout=min(numout,thisdim)

           outvalues(1:thisout)=laneigvals(1:thisout)

           if (printflag.ne.0) then
              OFL; write(mpifileptr,'(A10,1000F19.12)') " ENERGIES ", outvalues(1:thisout); CFL
           endif

           thisvalue(1:thisout)=outvalues(1:thisout)
           stopsum=0d0
           do nn=1,thisout
              rsum=abs(thisvalue(nn)-lastvalue(nn))
              if (rsum.gt.stopsum) then
                 stopsum=rsum
              endif
           enddo
           lastvalue(1:thisout)=thisvalue(1:thisout)

! so lanthresh is for error of HPsi...  empirically make guess (divided by 4) as to
!  when it might be converged based on change in energy

!!! flag=1 for maxiter,maxorder
           if ((thisout.eq.numout.and.stopsum.lt.lanthresh/4).or.flag.ne.0) then

              if (printflag.ne.0) then
                 OFL; write(mpifileptr,'(A25,2E12.5,I10)')  "checking convergence.",&
                      stopsum,lanthresh/10,thisdim; CFL
              endif

              outvectors = 0.0d0
              if (lansize.gt.0) then

                 do  j=1, numout
                    do k=1, iorder
                       do id=1,lanblocknum
                          if ((k-1)*lanblocknum+id.le.maxiter) then
                             outvectors(1:lansize,j) = outvectors(1:lansize,j) + &
                                  laneigvects(id,k,j) * lanvects(1:lansize,id,k)
                          endif
                       enddo
                    enddo
                 enddo

              endif  !! lansize

              if (lansize.eq.0) then
                 call vecnulldots(numout,normsq,logpar)
              else
                 call vecthisdots(outvectors(:,:),outvectors(:,:),lansize,&
                      outvectorlda,outvectorlda,numout,normsq,logpar)
              endif
              do  j=1, numout
                 outvectors(:,j)=outvectors(:,j)/sqrt(normsq(j))
              enddo

              tempvectors=0d0
              do j=1,numout
                 if (lansize.eq.0) then
                    call multsub(nullvector2(:),nullvector1(:))
                    call multsub(nullvector1(:),nullvector2(:))
                 else
                    call multsub(outvectors(:,j),tempvectors(:,j))
                    call multsub(tempvectors(:,j),tempvectors2(:,j))
                 endif
              enddo

              if (lansize.eq.0) then
                 call vecnulldots(numout,normsq,logpar)
                 call vecnulldots(numout,valdot,logpar)
                 call vecnulldots(numout,sqdot,logpar)
              else
                 call vechdots(outvectors(:,:),outvectors(:,:),lansize,outvectorlda,&
                      outvectorlda,numout,normsq,logpar)
                 call vechdots(outvectors(:,:),tempvectors(:,:),lansize,outvectorlda,&
                      maxlansize,numout,valdot,logpar)
                 call vechdots(outvectors(:,:),tempvectors2(:,:),lansize,outvectorlda,&
                      maxlansize,numout,sqdot,logpar)
              endif

              do j=1,numout
                 error(j)=abs(&
                      valdot(j)**2 / normsq(j)**2 - &
                      sqdot(j)/normsq(j))
              enddo
              if (printflag.ne.0) then
                 OFL; write(mpifileptr,'(A10,1000E9.2)') " ERRORS ", error(1:numout); CFL
              endif
              stopsum=0d0
              do nn=1,numout
                 if (error(nn).gt.stopsum) then
                    stopsum=error(nn)
                 endif
              enddo
              if (stopsum.gt.lanthresh) then
                 if (printflag.ne.0) then
                    OFLWR "Not converged", stopsum, lanthresh; CFL
                 endif
                 if (thisdim.ge.maxiter) then
                    OFLWR "MAX DIM REACHED, NO CONVERGENCE -- THRESHOLDS TOO HIGH? BUG?",&
                         stopsum,lanthresh; CFLST
                 endif
              else
                 flag=1
              endif
           endif
        endif
     enddo

     if (flag==1) then
        if (printflag.ne.0) then
           OFLWR "Converged. ",stopsum,lanthresh  !!, "HDOTS:"
!!$           do i=1,numout
!!$              write(mpifileptr,'(10000F8.3)') &
!!$                  (hdot(outvectors(:,i),outvectors(:,j),lansize,logpar),j=1,numout)
!!$           enddo
           CFL
        endif
     else
        flag=0
        OFLWR "  Not converged. restarting.", stopsum,lanthresh; CFL
     endif
  enddo

  deallocate(  invector,multvectors, lanvects, tempvectors, lanmultvects,tempvectors2)
  deallocate(followvects, followlandots )
  deallocate( lanham,       laneigvects,       laneigvals,       templanham)

contains

  function nulldot(logpar)
    implicit none
    logical,intent(in) :: logpar
    DATATYPE :: nulldot
    if (logpar) then
       nulldot=0d0
       call mympireduceone_local(nulldot,IN_COMM)
    else
       OFLWR "WHAT? nulldot called but not doing parallel calc... dimension zero???"; CFLST
    endif
  end function nulldot

  function hdot(bra,ket,n,logpar)
    implicit none
    integer,intent(in) :: n
    logical,intent(in) :: logpar
    DATATYPE,intent(in) :: bra(n),ket(n)
    DATATYPE :: hdot
    hdot=DOT_PRODUCT(bra,ket)
    if (logpar) then
       call mympireduceone_local(hdot,IN_COMM)
    endif
  end function hdot

  function thisdot(bra,ket,n,logpar)
    implicit none
    integer,intent(in) :: n
    logical,intent(in) :: logpar
    DATATYPE,intent(in) :: bra(n), ket(n)
    DATATYPE :: thisdot,csum,csum2
    integer :: ii
    csum2=0
!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(ii,csum)
    csum=0
!$OMP DO SCHEDULE(DYNAMIC)
    do ii=1,n
       csum=csum+CONJUGATE(bra(ii))*ket(ii)
    enddo
!$OMP END DO
!$OMP CRITICAL
    csum2=csum2+csum
!$OMP END CRITICAL
!$OMP END PARALLEL
    if (logpar) then
       call mympireduceone_local(csum2,IN_COMM)
    endif
    thisdot=csum2
  end function thisdot

  subroutine allhdots(bravectors,ketvectors,n,lda,num1,num2,outdots,logpar)
    implicit none
    integer,intent(in) :: num1,num2,lda,n
    logical,intent(in) :: logpar
    integer :: id,jd

    DATATYPE,intent(in) :: bravectors(lda,num1), ketvectors(lda,num2)
    DATATYPE,intent(out) :: outdots(num1,num2)

    if (n.le.0) then
       print *, "progerrrr"; stop
    endif

!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(id,jd)
!$OMP DO SCHEDULE(STATIC) COLLAPSE(2)
    do id=1,num1
       do jd=1,num2
          outdots(id,jd)= DOT_PRODUCT(bravectors(1:n,id),ketvectors(1:n,jd))
       enddo
    enddo
!$OMP END DO
!$OMP END PARALLEL
    if (logpar) then
       call mympireduce_local(outdots,num1*num2,IN_COMM)
    endif
  end subroutine allhdots

  subroutine allnulldots(num1,num2,outdots,logpar)
    implicit none
    integer,intent(in) :: num1,num2
    logical,intent(in) :: logpar
    DATATYPE,intent(out) :: outdots(num1,num2)

    if (logpar) then
       outdots(:,:)=0d0
       call mympireduce_local(outdots,num1*num2,IN_COMM)
    else
       OFLWR "WHAT? allnulldots called but not doing parallel calc... dimension zero???"; CFLST
    endif
  end subroutine allnulldots

  subroutine vechdots(bravectors,ketvectors,n,ldabra,ldaket,num,outdots,logpar)
    implicit none
    integer,intent(in) :: num,ldabra,ldaket,n
    logical,intent(in) :: logpar
    DATATYPE,intent(in) :: bravectors(ldabra,num), ketvectors(ldaket,num)
    DATATYPE,intent(out) :: outdots(num)
    integer :: id

    if (n.le.0) then
       print *, "progerrrrOR"; stop
    endif

!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(id)
!$OMP DO SCHEDULE(STATIC)
    do id=1,num
       outdots(id)= DOT_PRODUCT(bravectors(1:n,id),ketvectors(1:n,id))
    enddo
!$OMP END DO
!$OMP END PARALLEL
    if (logpar) then
       call mympireduce_local(outdots,num,IN_COMM)
    endif
  end subroutine vechdots

  subroutine vecthisdots(bravectors,ketvectors,n,ldabra,ldaket,num,outdots,logpar)
    implicit none
    integer,intent(in) :: num,ldabra,ldaket,n
    logical,intent(in) :: logpar
    DATATYPE,intent(in) :: bravectors(ldabra,num), ketvectors(ldaket,num)
    DATATYPE,intent(out) :: outdots(num)
    DATATYPE :: tempdots(num)
    integer :: ii,id

    if (n.le.0) then
       print *, "progerrrrxxx"; stop
    endif

    outdots(:)=0
!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(ii,id,tempdots)
    tempdots(:)=0
!$OMP DO SCHEDULE(DYNAMIC) COLLAPSE(2)
    do id=1,num
       do ii=1,n
          tempdots(id)=tempdots(id)+CONJUGATE(bravectors(ii,id))*ketvectors(ii,id)
       enddo
    enddo
!$OMP END DO
!$OMP CRITICAL
    outdots(:)=outdots(:)+tempdots(:)
!$OMP END CRITICAL
!$OMP END PARALLEL
    if (logpar) then
       call mympireduce_local(outdots,num,IN_COMM)
    endif
  end subroutine vecthisdots

  subroutine vecnulldots(num,outdots,logpar)
    implicit none
    integer,intent(in) :: num
    logical,intent(in) :: logpar
    DATATYPE,intent(out) :: outdots(num)

    if (logpar) then
       outdots(:)=0d0
       call mympireduce_local(outdots,num,IN_COMM)
    else
       OFLWR "WHAT? vecnulldots called but not doing parallel calc... dimension zero???"; CFLST
    endif
  end subroutine vecnulldots

! n is the length of the vectors; m is how many to orthogonalize to
  subroutine myhgramschmidt_fast(n, m, lda, previous, vector,logpar)
    implicit none
    integer,intent(in) :: n,m,lda
    DATATYPE,intent(in) :: previous(lda,m)
    DATATYPE,intent(inout) :: vector(n)
    DATATYPE :: norm,myhdots(m)
    logical,intent(in) :: logpar
    integer :: i,j

    if (n.le.0) then
       print *, "progerrrreeee"; stop
    endif

    do j=1,2

!!$ separate dot products for less numerical error; allhdots for speed

       if (m.ne.0) then
          call allhdots(previous(:,:),vector,n,lda,m,1,myhdots,logpar)
       endif

       do i=1,m
!!$        vector=vector-previous(1:n,i)* hdot(previous(1:n,i),vector(1:n),n,logpar)
!!$  only the same with previous perfectly orth
          vector=vector-previous(1:n,i)*myhdots(i)
       enddo
       norm=sqrt(hdot(vector,vector,n,logpar))
       vector=vector/norm
       if (abs(norm).lt.1e-7) then
          OFLWR "Gram schmidt norm",norm,m; CFL
       endif
    enddo
  end subroutine myhgramschmidt_fast

  subroutine nullgramschmidt_fast(m,logpar)
    implicit none
    integer,intent(in) :: m
    logical,intent(in) :: logpar
    DATATYPE :: norm,mynulldots(m)
    integer :: j

    do j=1,2

       if (m.ne.0) then
          call allnulldots(m,1,mynulldots,logpar)
       endif

!!$     do i=1,m
!!$        norm=nulldot(logpar)
!!$     enddo

       norm=sqrt(nulldot(logpar))
    enddo
  end subroutine nullgramschmidt_fast

!! DATAECS data type for values
  subroutine mysort2(inout, values,n,lda)
    implicit none
    integer,intent(in) :: lda, n
    DATATYPE,intent(inout) :: inout(lda,n)
    DATAECS,intent(inout) :: values(lda)
    DATAECS,allocatable ::  newvals(:)
    DATATYPE,allocatable :: out(:,:)
    integer,allocatable :: taken(:), order(:)
    real*8 :: lowval
    integer :: i,j,whichlowest, flag

    allocate(out(lda,n), newvals(lda), taken(lda), order(lda))

    taken=0;  order=-1
    do j=1,n
       whichlowest=-1; flag=0;     lowval=1.d+30  !! is not used (see flag)
       do i=1,n
          if ( taken(i) .eq. 0 ) then
             if ((flag.eq.0) .or.(abs(values(i)-etarget) .le. lowval)) then
                flag=1;              lowval=abs(values(i)-etarget); whichlowest=i
             endif
          endif
       enddo
       if ((whichlowest.gt.n).or.(whichlowest.lt.1)) then
          write(*,*) taken;        write(*,*)
          write(*,*) "WHICHLOWEST ERROR, J=",j," WHICHLOWEST=", whichlowest
          call mpistop()
       endif
       if (taken(whichlowest).ne.0) then
          write(*,*) "TAKEN ERROR.";        call mpistop()
       endif
       taken(whichlowest)=1;     order(j)=whichlowest
       out(:,j)=inout(:,order(j));     newvals(j)=values(order(j))
    enddo

    values(1:n)=newvals(1:n)
    inout(1:n,1:n)=out(1:n,1:n)

    deallocate(out, newvals, taken, order)

  end subroutine mysort2

  subroutine followsort(indim,inlandots)
    implicit none
    integer,intent(in) :: indim
    DATATYPE,intent(in) :: inlandots(numout,indim)
    DATATYPE,allocatable :: followdots(:,:), tempeigvect(:,:)
    DATAECS :: tempeigval
    real*8 :: rmaxdot
    integer :: i,j,ifollow

!!    OFLWR "Blocklan ifollow "; CFL

    allocate(followdots(numout,indim), tempeigvect(lanblocknum,order))

    followdots=0; tempeigvect=0;

    call MYGEMM('N','N',numout,indim,indim,DATAONE,inlandots(:,:),numout, &
         laneigvects(:,:,:),order*lanblocknum,DATAZERO,followdots(:,:),numout)

    do i=1,numout
       ifollow=(-1)
       rmaxdot=0d0
       do j=i,indim
          if (abs(followdots(i,j)).gt.rmaxdot) &
!!            do j=i, resorting, not needed:      .and.followtaken(j).eq.0) then
               then
             rmaxdot=abs(followdots(i,j))
             ifollow=j
          endif
       enddo

       if (ifollow.ne.i) then
          tempeigvect(:,:) = laneigvects(:,:,i)
          laneigvects(:,:,i) = laneigvects(:,:,ifollow)
          laneigvects(:,:,ifollow) = tempeigvect(:,:)

          tempeigval = laneigvals(i)
          laneigvals(i) = laneigvals(ifollow)
          laneigvals(ifollow) = tempeigval
       endif

!!       OFLWR "FF ",i,ifollow; CFL

    enddo

    deallocate(followdots, tempeigvect)

  end subroutine followsort

end subroutine blocklanczos0_local

subroutine blocklanczos(order,outvectors, outvalues,inprintflag,guessflag)
  use r_parameters
  use sparse_parameters
  use lanparameters
  use fileptrmod
  use configmod
  use parblocklanmod
  use basissubmod
  use mpisubmod
  implicit none
  integer, intent(in) :: order,inprintflag,guessflag
  integer :: printflag,maxdim,vdim,ii
  DATAECS, intent(out) :: outvalues(order)
  DATATYPE, intent(inout) :: outvectors(numr,www%firstconfig:www%lastconfig,order)
  DATATYPE,allocatable :: workvectorsspin(:,:,:), shufflevectors(:,:,:)
  DATATYPE :: nullvectors(numr,order)

  printflag=max(lanprintflag,inprintflag);    nullvectors=0

  if (sparseconfigflag.eq.0) then
     OFLWR "error, can't use blocklanczos for a-vector with sparseconfigflag=0"; CFLST
  endif

  allocate(workvectorsspin(numr,www%botdfbasis:www%topdfbasis,order))

  if (www%topdfbasis-www%botdfbasis+1.ne.0) then
     workvectorsspin(:,:,:)=0d0
     if (guessflag.ne.0) then
        do ii=1,order
           call basis_transformto_local(www,numr,outvectors(:,www%botconfig,ii),&
                workvectorsspin(:,:,ii))
        enddo
     endif
  endif

  maxdim=dwwptr%numdfbasis*numr
  vdim=(dwwptr%topdfbasis-dwwptr%botdfbasis+1)*numr

  call mpibarrier()
  if (use_dfwalktype.and.shuffle_dfwalktype) then
     allocate(shufflevectors(numr,dwwptr%botdfbasis:dwwptr%topdfbasis,order))
     if (dwwptr%topdfbasis.ge.dwwptr%botdfbasis) then
        shufflevectors=0
     endif
     call basis_shuffle_several(numr,www,workvectorsspin,dwwptr,shufflevectors,order)
  else
     allocate(shufflevectors(numr,1,order))
  endif

  if (use_dfwalktype.and.shuffle_dfwalktype) then
     if (nzflag.eq.0.or.dwwptr%nzrank.gt.0) then
        call blocklanczos0_local(order,order,vdim,vdim,lanczosorder,maxdim,shufflevectors,vdim,&
             outvalues,printflag,guessflag,lancheckstep,lanthresh,parblockconfigmult,&
             .true.,0,DATAZERO,dwwptr%NZ_COMM)
     else
        if (dwwptr%topdfbasis.ge.dwwptr%botdfbasis) then
           shufflevectors=0
        endif
     endif
  else
     if (nzflag.eq.0.or.dwwptr%nzrank.gt.0) then
        call blocklanczos0_local(order,order,vdim,vdim,lanczosorder,maxdim,workvectorsspin,vdim,&
             outvalues,printflag,guessflag,lancheckstep,lanthresh,parblockconfigmult,&
             .true.,0,DATAZERO,dwwptr%NZ_COMM)
     else
        if (dwwptr%topdfbasis.ge.dwwptr%botdfbasis) then
           workvectorsspin=0d0
        endif
     endif
  endif

  call mpibarrier()

  if (use_dfwalktype.and.shuffle_dfwalktype) then
     call basis_shuffle_several(numr,dwwptr,shufflevectors,www,workvectorsspin,order)
  endif
  deallocate(shufflevectors)

!  if (printflag.ne.0) then
!     OFLWR "Done with blocklanczos0_local."; CFL
!  endif

  if (www%lastconfig.ge.www%firstconfig) then
     outvectors(:,:,:)=0d0
  endif

  if (www%topdfbasis-www%botdfbasis+1.ne.0) then
     do ii=1,order
        call basis_transformfrom_local(www,numr,workvectorsspin(:,:,ii),&
             outvectors(:,www%botconfig,ii))
     enddo
  endif

  deallocate(workvectorsspin)

  if (www%parconsplit.eq.0) then
     do ii=1,order
        call mpiallgather(outvectors(:,:,ii),www%numconfig*numr,&
             www%configsperproc(:)*numr,www%maxconfigsperproc*numr)
     enddo
  endif

end subroutine blocklanczos

end module lanblockmod


!Wapening
W_Diameter = 16 / 1000 !16 mm
W_Straal = W_Diameter / 2
W_Dekking_x = 11 / 1000
W_Dekking_y = 11 / 1000
W_Halve_Lengte = S_Lengte/2 - (75 / 1000) !wapening stopt iets voor het einde van de ligger.

!Call rest of the default parameters
/INPUT, parameters, f, '%GeometryFolder(1)%' , 0, 1


      module comsi
!***********************************************************************
! Copyright 2008 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!***********************************************************************
!D1
!D1 PURPOSE
!D1
!D1 Global include file for array variables (FEHMN application).
!D1 Coupled Fluid Stress application
!D1
!***********************************************************************
!D2
!D2 REVISION HISTORY
!D2
!D2 Revision                    ECD
!D2 Date         Programmer     Number  Comments
!D2
!D2 06-June_2002  G. Zyvoloski           Initial implementation.
!D2
!***********************************************************************

      integer flag_permmodel
      integer incremental_shear_permmodel

      integer icycs,ipsps,iinp,minks,inst,ipchng,nnx,ihms,nvfc
      integer nomass,noheat,noydis,localx,localy,ifrac,idof_stress
      integer ibp_stress, ibodyforce, ipermstr, initcalc, istrshis
      integer ispmd,ipermstr1,ipermstr2,ipermstr3
      integer ipermstr4,ipermstr5,ipermstr6,ipermstr7,ipermstr8
      integer ipermstr11,ipermstr21,ipermstr22,ipermstr222
      integer ipermstr23, ipermstr24, ipermstr25
      integer ipermstr91, ipermstr31, ipermstr100
      integer istresscall,ilitho,iad_strs,istresspor,idisp_rel
      integer cnum_stress, ilithgrad, permfile

      integer isNonlinear, Nonlin_model_flag, flag_principal
c gaz 031017
      integer isbiotNonLin
      integer flag_excess_shear

      real*8 friction_out,strength_out, pp_fac_out
      real*8 daystr,fpor,fric,wo,fwght,fupwt,fdnwt,tol_stress
      real*8 tptch,pchmin,pchmax,tchmin,tchmax,coftol,bp_stress
      real*8 bpx,bpy,bpz,tol_stress1,abs_tol_stress,bp_update
      real*8 vol_tot_change, daystress, timestress, timestress0
      real*8 strx_min,stry_min,strz_min,perx_m,pery_m,perz_m
      real*8 e10_facx,e10_facy,e10_facz,elev_high,pres_elev
      real*8 tenslie_str_fac,area_str_zone
      parameter (tensile_str_fac = 10.d0)
      integer, allocatable :: kr(:,:)
      integer, allocatable :: npbn(:)
      integer, allocatable :: nvfcl(:)
      integer, allocatable :: ispmt(:)
      integer, allocatable :: ispm(:)
      integer, allocatable :: nskw_stress(:,:)
      integer, allocatable :: frac_flg(:)

      real*8, allocatable ::  elastic_mod(:)
      real*8, allocatable ::  poisson(:)
      real*8, allocatable ::  e1(:)
      real*8, allocatable ::  e2(:)
      real*8, allocatable ::  e3(:)
c s kelkar 12/6/09 axisymmetric anisotropy
      logical stress_anisotropy_in,stress_anisotropy_use
        real*8, allocatable ::  elastic_mod_t(:)
        real*8, allocatable ::  poisson_t(:)
        real*8, allocatable ::  e4(:)
        real*8, allocatable ::  ezz(:)
        real*8, allocatable ::  shearmod_t(:)
c d dempsey 03/11/14 bodyforce vector
      real*8, allocatable ::  bodyforce_x(:)
      real*8, allocatable ::  bodyforce_y(:)
      real*8, allocatable ::  bodyforce_z(:)

c......................................
c sai - variables needed for plasticity
       integer iPlastic, initPlastic, assemblePlastic
       integer NumPlasticModels

       integer, allocatable :: row(:,:,:), col(:,:,:)

       integer, allocatable::  plasticModel(:)
       integer, allocatable::  modelNumber(:)

       integer, allocatable::  isPlastic(:,:)
       real*8, allocatable ::  plastic_strain(:,:)
       real*8, allocatable ::  plasticParam1(:)
       real*8, allocatable ::  plasticParam2(:)

       real*8, allocatable ::  delta_u(:)
       real*8, allocatable ::  delta_v(:)
       real*8, allocatable ::  delta_w(:)

       real*8, allocatable ::  yield_stress(:)
       real*8, allocatable ::  hardening(:)

       real*8, allocatable ::  strain_xx(:)
       real*8, allocatable ::  strain_yy(:)
       real*8, allocatable ::  strain_zz(:)
       real*8, allocatable ::  strain_xy(:)
       real*8, allocatable ::  strain_yz(:)
       real*8, allocatable ::  strain_zx(:)

c......................................
c k yoshioka 3/2/10 orthotropy
      logical stress_orthotropy
      real*8, allocatable :: elastic_mod_2(:)
      real*8, allocatable :: elastic_mod_3(:)
      real*8, allocatable :: poisson_13(:)
      real*8, allocatable :: poisson_23(:)
      real*8, allocatable :: shearmod_12(:)
      real*8, allocatable :: shearmod_13(:)
      real*8, allocatable :: shearmod_23(:)
      real*8, allocatable :: e5(:)
      real*8, allocatable :: e6(:)
      real*8, allocatable :: bulk1(:)
      real*8, allocatable :: bulk2(:)
      real*8, allocatable :: bulk3(:)
c.........................................
      real*8, allocatable ::  bulk(:)
      real*8, allocatable ::  alp(:)
c gaz 042917 added initial thermal and bulk modulus
      real*8, allocatable ::  bulk0(:)
      real*8, allocatable ::  alp0(:)
      real*8, allocatable ::  du(:)
      real*8, allocatable ::  dv(:)
      real*8, allocatable ::  dw(:)
      real*8, allocatable ::  duo(:)
      real*8, allocatable ::  dvo(:)
      real*8, allocatable ::  dwo(:)
      real*8, allocatable ::  du_ini(:)
      real*8, allocatable ::  dv_ini(:)
      real*8, allocatable ::  dw_ini(:)
      real*8, allocatable ::  du_tot(:)
      real*8, allocatable ::  dv_tot(:)
      real*8, allocatable ::  dw_tot(:)
      real*8, allocatable ::  sxx(:)
      real*8, allocatable ::  syy(:)
      real*8, allocatable ::  szz(:)
      real*8, allocatable ::  epsxx(:)
      real*8, allocatable ::  epsyy(:)
      real*8, allocatable ::  epszz(:)
      real*8, allocatable ::  sxy(:)
      real*8, allocatable ::  syz(:)
      real*8, allocatable ::  szx(:)
      real*8, allocatable ::  epsxy(:)
      real*8, allocatable ::  epsyz(:)
      real*8, allocatable ::  epszx(:)
      real*8, allocatable ::  str_x(:)
      real*8, allocatable ::  str_y(:)
      real*8, allocatable ::  str_z(:)
      real*8, allocatable ::  str_x0(:)
      real*8, allocatable ::  str_y0(:)
      real*8, allocatable ::  str_z0(:)
      logical residual_stress
c Bai model
      real*8, allocatable ::  estr_x0(:)
      real*8, allocatable ::  estr_y0(:)
      real*8, allocatable ::  estr_z0(:)
      real*8, allocatable ::  estr_xy0(:)
      real*8, allocatable ::  estr_xz0(:)
      real*8, allocatable ::  estr_yz0(:)
c Failure + Bai displacement
      real*8, allocatable ::  es_f_x0(:,:)
      real*8, allocatable ::  es_f_y0(:,:)
      real*8, allocatable ::  es_f_z0(:,:)
      real*8, allocatable ::  s_f_xy0(:,:)
      real*8, allocatable ::  s_f_xz0(:,:)
      real*8, allocatable ::  s_f_yz0(:,:)
      real*8, allocatable ::  frc_zen(:,:)
      real*8, allocatable ::  frc_azm(:,:)
cccccccccccccccccccccccccccccccccccccccccccccccheck
      real*8,  allocatable ::  check(:)
c     ___________________________________________
      real*8, allocatable ::  str_xy(:)
      real*8, allocatable ::  str_xz(:)
      real*8, allocatable ::  str_yz(:)
      real*8, allocatable ::  str_xy0(:)
      real*8, allocatable ::  str_xz0(:)
      real*8, allocatable ::  str_yz0(:)
      real*8, allocatable ::  asxx(:)
      real*8, allocatable ::  asyy(:)
      real*8, allocatable ::  disp(:,:)
      real*8, allocatable ::  forc(:,:)
      real*8, allocatable ::  phistr(:)
      real*8, allocatable ::  tmpstr(:)
      real*8, allocatable ::  dluf(:)
      real*8, allocatable ::  dlvf(:)
      real*8, allocatable ::  shp(:)
      real*8, allocatable ::  sht(:)
      real*8, allocatable ::  uxtp(:)
      real*8, allocatable ::  uytp(:)
      real*8, allocatable ::  uztp(:)
      real*8, allocatable ::  dmadv(:)
      real*8, allocatable ::  deadv(:)
      real*8, allocatable ::  drluf(:)
      real*8, allocatable ::  drlvf(:)
      real*8, allocatable ::  rlxs(:)
      real*8, allocatable ::  rlys(:)
      real*8, allocatable ::  rlzs(:)
      real*8, allocatable ::  drlxs(:,:)
      real*8, allocatable ::  drlys(:,:)
      real*8, allocatable ::  drlzs(:,:)
      real*8, allocatable ::  drlxv(:,:)
      real*8, allocatable ::  drlzv(:,:)
      real*8, allocatable ::  dflv(:)
      real*8, allocatable ::  dvfdv(:,:)
      real*8, allocatable ::  vol_strain(:)
      real*8, allocatable ::  vol_strain0(:)
      real*8, allocatable ::  dvol_strainu(:)
      real*8, allocatable ::  dvol_strainv(:)
      real*8, allocatable ::  dvol_strainw(:)
      real*8, allocatable ::  vol_temp(:)
      real*8, allocatable ::  pnx0(:)
      real*8, allocatable ::  pny0(:)
      real*8, allocatable ::  pnz0(:)
      real*8, allocatable ::  e10(:)
      real*8, allocatable ::  e20(:)
      real*8, allocatable ::  e30(:)

      integer, allocatable ::   itstress(:)

      real*8 ftoll
      real*8, allocatable ::  af(:,:)
      real*8, allocatable ::  cf(:,:)
      real*8, allocatable ::  stifi(:,:)
      real*8, allocatable ::  sigfi(:,:)
      real*8, allocatable ::  vm(:,:)
      real*8, allocatable ::  dlvy(:)
      real*8, allocatable ::  dlux(:)
      real*8, allocatable ::  dsx(:)
      real*8, allocatable ::  dsy(:)

c     common/fracturex/dla(n0),dlb(n0),dmpm(n0),dmtm(n0),
c     $    dmu(n0), dmv(n0),depm(n0),detm(n0),deu(n0),dev(n0),
c     $    akkx(n0),akky(n0), aiio(n0),biio(n0),
c     $    ffx(n0),ffy(n0)

      real*8, allocatable ::  dla(:)
      real*8, allocatable ::  dlb(:)
      real*8, allocatable ::  dmpm(:)
      real*8, allocatable ::  dmtm(:)
      real*8, allocatable ::  dmu(:)
      real*8, allocatable ::  dmv(:)
      real*8, allocatable ::  depm(:)
      real*8, allocatable ::  detm(:)
      real*8, allocatable ::  deu(:)
      real*8, allocatable ::  dev(:)
      real*8, allocatable ::  akkx(:)
      real*8, allocatable ::  akky(:)
      real*8, allocatable ::  aiio(:)
      real*8, allocatable ::  biio(:)
      real*8, allocatable ::  ffx(:)
      real*8, allocatable ::  ffy(:)

c     dimension a12mpf(n0),a12mef(n0),a12eef(n0)

      real*8, allocatable ::  a12mpf(:)
      real*8, allocatable ::  a12mef(:)
      real*8, allocatable ::  a12eef(:)

      integer, allocatable ::  icxuani(:)
      integer, allocatable ::  icxvani(:)
      integer, allocatable ::  icxwani(:)
      integer, allocatable ::  icyuani(:)
      integer, allocatable ::  icyvani(:)
      integer, allocatable ::  icywani(:)
      integer, allocatable ::  iczuani(:)
      integer, allocatable ::  iczvani(:)
      integer, allocatable ::  iczwani(:)

      integer, allocatable ::  ncon_xu1(:)
      integer, allocatable ::  ncon_xv1(:)
      integer, allocatable ::  ncon_xw1(:)
      integer, allocatable ::  ncon_yu1(:)
      integer, allocatable ::  ncon_yv1(:)
      integer, allocatable ::  ncon_yw1(:)
      integer, allocatable ::  ncon_zu1(:)
      integer, allocatable ::  ncon_zv1(:)
      integer, allocatable ::  ncon_zw1(:)

      integer, allocatable ::  ncon_xu2(:)
      integer, allocatable ::  ncon_xv2(:)
      integer, allocatable ::  ncon_xw2(:)
      integer, allocatable ::  ncon_yu2(:)
      integer, allocatable ::  ncon_yv2(:)
      integer, allocatable ::  ncon_yw2(:)
      integer, allocatable ::  ncon_zu2(:)
      integer, allocatable ::  ncon_zv2(:)
      integer, allocatable ::  ncon_zw2(:)

      integer, allocatable ::  istrws(:)

      real*8, allocatable ::  sx_xu(:)
      real*8, allocatable ::  sx_xv(:)
      real*8, allocatable ::  sx_xw(:)
      real*8, allocatable ::  sx_yu(:)
      real*8, allocatable ::  sx_yv(:)
      real*8, allocatable ::  sx_yw(:)
      real*8, allocatable ::  sx_zu(:)
      real*8, allocatable ::  sx_zv(:)
      real*8, allocatable ::  sx_zw(:)

      real*8, allocatable ::  sx_temp_xu(:,:,:)
      real*8, allocatable ::  sx_temp_xv(:,:,:)
      real*8, allocatable ::  sx_temp_xw(:,:,:)
      real*8, allocatable ::  sx_temp_yu(:,:,:)
      real*8, allocatable ::  sx_temp_yv(:,:,:)
      real*8, allocatable ::  sx_temp_yw(:,:,:)
      real*8, allocatable ::  sx_temp_zu(:,:,:)
      real*8, allocatable ::  sx_temp_zv(:,:,:)
      real*8, allocatable ::  sx_temp_zw(:,:,:)

      integer, allocatable ::  idum_str(:,:)
      real*8, allocatable ::   dum_str(:,:)
      integer, allocatable ::  idum_str1(:)

      integer, allocatable :: ipermx(:,:)
      integer, allocatable :: ipermy(:,:)
      integer, allocatable :: ipermz(:,:)
      real*8, allocatable ::  bp_flow1(:)
      real*8, allocatable ::  bp_flow2(:)

      real*8, allocatable ::  spm1f(:)
      real*8, allocatable ::  spm2f(:)
      real*8, allocatable ::  spm3f(:)
      real*8, allocatable ::  spm4f(:)
      real*8, allocatable ::  spm5f(:)
      real*8, allocatable ::  spm6f(:)
      real*8, allocatable ::  spm7f(:)
      real*8, allocatable ::  spm8f(:)
      real*8, allocatable ::  spm9f(:)
      real*8, allocatable ::  spm10f(:)
      real*8, allocatable ::  spm11f(:)
      real*8, allocatable ::  spm12f(:)
      real*8, allocatable ::  spm13f(:)
      real*8, allocatable ::  spm14f(:)
      real*8, allocatable ::  spm15f(:)
      real*8, allocatable ::  spm16f(:)
      real*8, allocatable ::  spm1f222(:)
      real*8, allocatable ::  spm2f222(:)
      real*8, allocatable ::  spm3f222(:)
      real*8, allocatable ::  spm4f222(:)
      real*8, allocatable ::  spm5f222(:)
      real*8, allocatable ::  spm6f222(:)
      real*8, allocatable ::  spm7f222(:)
      real*8, allocatable ::  spm8f222(:)
      real*8, allocatable ::  spm9f222(:)
      real*8, allocatable ::  spm10f222(:)

      real*8, allocatable ::  flitho(:,:)

      integer, allocatable ::  iarea_str(:,:)
      real*8, allocatable ::  area_str(:,:)

      real*8 frac_vol

c     For Min model
      real*8 ipmd4_fx,ipmd4_br,ipmd4_bmx,ipmd4_alx,ipmd4_aly
      real*8 ipmd4_fdx,ipmd4_dmx,ipmd4_gmx,ipmd4_kc
      real*8 ipmd4_fy,ipmd4_btx,ipmd4_bty, ipmd4_fdy,ipmd4_gmy

c s kelkar
      integer flag_strainout_first
      integer flag_strain_output, ifile_strain,n_incr
      integer nentries, nentries_young
      real*8, allocatable ::  e_ini(:), poisson_ini(:)
      real*8, allocatable ::   dNuedt(:)
      real*8, allocatable ::  dEdt(:)
      real*8, allocatable ::  xtan_min(:)
      real*8, allocatable ::  disp0(:,:)
      real*8, allocatable ::  k_strs91(:,:)
c      real*8, allocatable ::  e_temp91(:,:)
c gaz 042116
c
      real*8, allocatable ::  e_temp91(:,:,:)
      real*8, allocatable ::  t_non_ref(:)
      integer, allocatable ::  i_tab_youngs(:)
      integer, allocatable ::  iy_tab(:)
      integer, allocatable ::  istr_non_model(:)
      integer  max_y_tab, n_young_table, nentries_young_max
      integer max_non_str, nentries_biot
      parameter (max_non_str = 100)
      parameter (max_y_tab = 100,nentries_young_max = 10000)
c
c gaz 042116
c
      real*8, allocatable ::  biot_temp91(:,:,:)
      real*8, allocatable ::  biot_t_non_ref(:)
      integer, allocatable ::  i_tab_biot(:)
      integer, allocatable ::  iy_tab_biot(:)
      integer, allocatable ::  istr_non_model_biot(:)
      integer  max_y_tab_b, n_biot_table, nentries_biot_max
      integer max_non_str_biot
      parameter (max_non_str_biot = 100)
      parameter (max_y_tab_b = 100,nentries_biot_max = 10000)

      real*8 knx_stressperm, kny_stressperm,knz_stressperm

      real*8, allocatable ::  excess_shear(:)
      real*8, allocatable ::  shear_angle(:)
      real*8 pore_factor

      real*8, allocatable ::  density(:), internal_energy(:)

      integer, allocatable ::  itemp_perm22(:)
      integer, allocatable ::  itemp_perm23(:)

c s karra 17May 2012
      real*8, allocatable ::  plasticParam3(:)
      integer :: flag_pstrain_perm_coupling
c
c s kelkar for permmodel_22 zero out initial excess hsear stress
      real*8, allocatable ::  str_x0_perm(:)
      real*8, allocatable ::  str_y0_perm(:)
      real*8, allocatable ::  str_z0_perm(:)
      real*8, allocatable ::  str_xy0_perm(:)
      real*8, allocatable ::  str_xz0_perm(:)
      real*8, allocatable ::  str_yz0_perm(:)
      real*8, allocatable ::  str_pf0_perm(:)

c d dempsey, for permmodel_25, save fracture orientations from file
      real*8, allocatable ::  str25_dip(:)
      real*8, allocatable ::  str25_azi(:)
      real*8, allocatable ::  str25_xfrac(:,:)
      real*8, allocatable ::  str25_yfrac(:,:)
      real*8, allocatable ::  str25_zfrac(:,:)
      real*8, allocatable ::  perm_mult1(:)
      real*8, allocatable ::  perm_mult2(:)
      real*8, allocatable ::  perm_mult3(:)
      real*8 str25_density(1000)
      integer str25_N_obs

c gaz 110517
      real*8 eigenvec(3,3),alambda(3), eigenvec_deg(3)

      end module comsi


       subroutine fitfun(mf, nx, xvar, fvec, iend)
c
c//////////////////////////////////////////////////////////////////////
c Copyright (c) 1997--2000 Matthew Newville, The University of Chicago
c Copyright (c) 1992--1996 Matthew Newville, University of Washington
c
c Permission to use and redistribute the source code or binary forms of
c this software and its documentation, with or without modification is
c hereby granted provided that the above notice of copyright, these
c terms of use, and the disclaimer of warranty below appear in the
c source code and documentation, and that none of the names of The
c University of Chicago, The University of Washington, or the authors
c appear in advertising or endorsement of works derived from this
c software without specific prior written permission from all parties.
c
c THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
c EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
c MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
c IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
c CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
c TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
c SOFTWARE OR THE USE OR OTHER DEALINGS IN THIS SOFTWARE.
c//////////////////////////////////////////////////////////////////////
c
c purpose:  feffit fitting function for lmdif1 minimization
c
c arguments:
c      mf       number of points in ffit             [in]
c      nx       number of points in xv               [in]
c      xv       vector of variables                  [in]
c      fvec     output vector to be minimized        [out]
c      iend     information tag                      [out]
       implicit none
       include 'consts.h'
       include 'arrays.h'
       include 'keywrd.h'
       include 'fft.h'
       include 'fefdat.h'
       include 'pthpar.h'
       include 'feffit.h'
c local variables
       integer    nx, mf, iend, i,  id, isp, nx1, iter
       integer    jfit, nqdata, nfit1, nkpar, npaths
       integer    iupath(mpaths), inxx, ixx, joff, jqw
       integer   ier, iff_eval_dp
       double precision xvar(nx), fvec(mf), xolow, xohigh, bvalue
       double precision getsca, xspl(mtknot), bx, qx, sum, tmpval
       double precision xsum, sumsqr
       character  arg*2
       integer    isarg, ilen, istrln, j, nmx
       external   bvalue, getsca,  istrln, iff_eval_dp, sumsqr
       save
c
       nkpar = 0
       id    = 1
       if (nx.ne.nvarys) iend = 1
       if (mf.ne.mfit)   iend = 2
       nx1 = nx - nbkg(id)
cc       print*, 'FITFUN N_vars:',nx,mf,nfdats
       do 20 i = 1, nx
          scalar(i) = xvar(i)
 20    continue
       call synvar
cc       print*, 'VARS ', xvar(1), xvar(2), xvar(3), xvar(4)
       if (final) rfact_total = zero
c
c  sum function to minimize over data sets
c   jfit is the counter (through all the data sets)
c   for the total number of fitting points

       jfit = 0
       do 3000 id = 1, nfdats
          nqdata = min(maxpts, max(2, nqfit(id)) + 10)
          if (ifft(id).eq.1) then
             xolow  = rmin(id)
             xohigh = rmax(id)
          else
             xolow  = qmin(id)
             xohigh = qmax(id)
          endif
          do 200 i = 1, nfit(id)*nqwfs(id)
             thifit(i)   = zero
 200      continue
c  re-initialize array for theoretical chi(k)
c  by assigning this to the background function
          do 300 i = 1, nqdata
             thiq(i, id) = zero
             thiqr(i, id) = zero
 300      continue
c
c sum over paths for theory chi for this data set
          npaths = 0
          do 400 i = 1, mpaths
             iupath(i) = 0
             if (iulist(i,id).ne.0) then
                npaths = npaths + 1
                iupath(npaths) = iulist(i,id)
             end if
 400      continue
          call sum_paths(id, iupath, npaths, nqdata,
     $         thiqr(1,id), thiq(1,id))
c
c if refining background, include that here
          if ( bkgfit(id))  then
             do 450 isp = 1, nbkg(id)
                write(tmpstr, '(a,i2.2,a,i2.2)') 'bkg',id,'_',isp
                xspl(isp) = getsca(tmpstr,0)
cc                print*, 'FITFUN i ' , isp, xspl(isp)
 450         continue
             do 470 i = 1, nqdata
                qx = qgrid*(i-1)
                thiq(i, id) = thiq(i, id) +
     $               bvalue(qknot(1,id), xspl, nbkg(id),korder,qx,0)
 470         continue
          end if
c
c subtract data from theory
          do 500 i = 1, nqdata
             thiq(i,id) = thiq(i,id)-chiq(i,id)
 500      continue
c
c loop over k-weights for multiple k-weights
c    top down, so that the first k-weight listed is done last
c
          do 1000 jqw = nqwfs(id), 1, -1
             qweigh(id) = qwfs(jqw,id)

c   take fft of theory(+bkg) - data
c   note: imag part of theory chi(k) compares to real part of data!!!
c   see ff2chi as well
             call fitfft(thiq(1,id), maxpts, maxfft, wfftc, qgrid,
     $            qwindo(1,id), qwfs(jqw,id), rwindo(1,id), one,
     $            ifft(id),modeft(id),xolow,xohigh, nfit1, thifit)

             if (nfit1.ne.nfit(id)) then
                call warn(3,' fitfun fitfft failed internal test.')
                iend = -10
             end if
c
c  evaluate the contribution to fvec for this data set.  weight scales
c  chi-square properly to the number of independent points. this is
c  important for error analysis (if chi-square is to increase by one,
c  it  must be scaled correctly.), but only in the final pass, when
c  chi-square and r-factors will be calculated.
c             print*, 'fitfun ', jfit, jqw, id,
c     $            weight(jqw, id), nfit(id), thifit(1), thifit(2)
             do 700 i =  1, nfit(id)
                fvec(jfit+i) = (thifit(i))/weight(jqw,id)
 700         continue

             jfit = jfit + nfit(id)

c construct r-factor
             if (final) then
                call fitfft(chiq(1,id), maxpts, maxfft, wfftc, qgrid,
     $               qwindo(1,id), qwfs(jqw,id), rwindo(1,id), one,
     $               ifft(id),modeft(id),xolow,xohigh, nfit1, chifit)
                if (nfit1.ne.nfit(id)) then
                   call warn(3,' fitfun fitfft failed internal test.')
                   iend = -10
                end if

                sum        = zero
                rfactr(id) = zero
                do 800 i = 1, nfit(id)
                   sum        = sum        + chifit(i)*chifit(i)
                   rfactr(id) = rfactr(id) + thifit(i)*thifit(i)
 800            continue
                if (sum.le.tiny) sum = tiny
                rfactr(id)  =  rfactr(id) / (sum * nqwfs(id))
                rfact_total = rfact_total + rfactr(id)
cc                print*, ' final ', sum, rfactr(id), id, rfact_total
             end if
c
c  restraints
             if (nrestraint(id).ge.1) then
cc                print*, ' RESTRAINT ', nrestraint(id), id, jfit
                do 900 i =  1, nrestraint(id)
                   if ( (restraint(i,id) .ne. undef).and.
     $                  (restraint(i,id) .ne. '')) then
                      ier    = iff_eval_dp(restraint(i,id),tmpval)
                      if (ier.eq.0) then
                         jfit   = jfit + 1
                         fvec(jfit) = tmpval
cc                         print*, ' t: ', tmpval, jfit, ier
                      endif
                   endif
 900            continue
             endif
 1000     continue   ! end loop over k-weights
cc          print*, ' end of ndata loop  ', id, nfit(id), jfit
 3000  continue      ! end loop over data sets

       if (final) rfact_total = rfact_total / max(1,nfdats)

c
c execute user-defined macro
       iter  =  int(getsca('&fit_iteration',0))
       if (iter.gt.itera) then
          itera = iter
          xsum = sumsqr(fvec,jfit)
cc          print*, ' iteration ', iter, mf,mfit,jfit,nfdats, xsum
          if (ifit_mac.gt.0) then
             call iff_macro_do(ifit_mac, fit_m_arg, 0,.false.)
          end if

       end if
       return
c end subroutine fitfun
       end


module sirMod
use iso_c_binding, only: c_int, c_float

implicit none

integer, parameter :: kt=400      !maximum number of depth points (64)
integer, parameter :: kn=400      !maximum number of nodes (64)
integer, parameter :: kl=10       !maximum number of lines (100)
integer, parameter :: kld=5000    !maximum number of wavelengths (600)
integer, parameter :: mfitmax=200 !maximum number of total nodes (200)
integer, parameter :: kld4=4*kld, kldt=kld*kn, kldt4=4*kldt, kt8=8*kt+2

contains

	subroutine c_init(nLambda) bind(c)
	integer(c_int), intent(out) :: nLambda

	integer :: i, j, ifiltro
	integer ntl,nlin(kl),npas(kl),nble(kl)
	real*4 dlamda(kld)
	common/Malla/ntl,nlin,npas,nble,dlamda
	common/ifiltro/ifiltro

		call leyendo

! contamos el numero de puntos
		nLambda = 0
		do i=1,ntl
        	do j=1,npas(i)
	      		nLambda = nLambda + 1
	    	end do
		end do

		ifiltro = 0

	end subroutine c_init

	subroutine c_setpsf(nPSF, xPSF, yPSF) bind(c)
	integer(c_int), intent(in) :: nPSF
	real(c_float), intent(in) :: xPSF(nPSF), yPSF(nPSF)
	integer :: i, j
	integer, parameter :: nmx=401
	real*4 x(nmx), y(nmx)
	character*100 filtro
	integer ifiltro, num
	common/filtro/filtro,x,y,num                 !para pasar el nombre de la PSF
    common/ifiltro/ifiltro

		ifiltro = 1
    	do i = 1, nPSF
    		x(i) = xPSF(i)
    		y(i) = yPSF(i)
    	enddo
    	num = nPSF

	end subroutine c_setpsf

	subroutine c_synth(nDepth, nLambda, macroturbulence, filling, stray, model, stokes) bind(c)
	integer(c_int), intent(in) :: nDepth, nLambda
	real(c_float), intent(in) :: model(8,ndepth)
	real(c_float), intent(in) :: macroturbulence, filling, stray
	real(c_float), intent(out) :: stokes(5,nLambda)

	real*4 stok(kld4)
    real*4 rt(kldt4),rp(kldt4),rh(kldt4),rv(kldt4)
    real*4 rg(kldt4),rf(kldt4),rm(kldt4), rmac(kld4)
    integer ist(4),i,k,ntot, j, l, itau
	integer ntl,nlin(kl),npas(kl),nble(kl)
	real*4 dlamda(kld)
	character*100 Stokesfilename
	integer*4 mnodos(18), ntau
	real*4 atmosmodel(kt8), pesostray
	real*4 tau(kt),t(kt),pe(kt),pg(kt),z(kt),ro(kt)
	real*4 voffset,xmu
	common/Malla/ntl,nlin,npas,nble,dlamda  !common para StokesFRsub
    common/OutputStokes/Stokesfilename

    common/Atmosmodel/atmosmodel,ntau !common para StokesFRsub
	common/numeronodos/mnodos         !para StokesFRsub
    common/offset/voffset             !para StokesFRsub
    common/anguloheliocent/xmu        !para StokesFRsub

	    ntau = nDepth

! offset de velocidad para perturbaciones relativas necesitamos que la velocidad sea siempre positiva
		voffset=-15.e5    !cm/s
	    xmu=1.            !coseno del angulo heliocentrico

! Put the model in vectorized form
		atmosmodel(8*ntau+1) = macroturbulence
		atmosmodel(8*ntau+2) = filling
		pesostray = stray
		do i = 1, ntau
			do j = 0, 7
				atmosmodel(i+j*ntau) = model(j+1,i)
			enddo
			tau(i) = atmosmodel(i)
			t(i) = atmosmodel(i+ntau)
			pe(i) = atmosmodel(i+2*ntau)
		enddo

! pasamos los angulos a radianes
		call taulinea(0,1.,1,0.,atmosmodel,ntau)

! definimos los nodos en todos los puntos (excepto para ls presion elctronica)
		do i=1,8
        	mnodos(i)=0
		end do
    	mnodos(2)=0

! Compute hydrostatic equilibrium if necessary
    	if (minval(model(3,:)) == -1) then
    		call equisubmu(ntau,tau,t,pe,pg,z,ro)

        	do i=1,ntau
            	atmosmodel(i+2*ntau)=pe(i)
        	end do
        endif

		call StokesFRsub(stok,rt,rp,rh,rv,rg,rf,rm,rmac)

! contamos el numero de puntos
		ntot=0
		do i=1,ntl
        	do j=1,npas(i)
	      		ntot=ntot+1
	    	end do
		end do

! Output Stokes parameters
		stokes(1,:) = dlamda(1:ntot)
		stokes(2,:) = stok(1:ntot)
		stokes(3,:) = stok(ntot+1:2*ntot)
		stokes(4,:) = stok(2*ntot+1:3*ntot)
		stokes(5,:) = stok(3*ntot+1:4*ntot)

	end subroutine c_synth

	subroutine c_synthrf(nDepth, nLambda, macroturbulence, filling, stray, model, stokes, RFt, RFp, RFh, RFv, RFg, RFf, RFmic, RFmac) bind(c)
	integer(c_int), intent(in) :: nDepth, nLambda
	real(c_float), intent(in) :: model(8,ndepth)
	real(c_float), intent(in) :: macroturbulence, filling, stray
	real(c_float), intent(out) :: stokes(5,nLambda)
	real(c_float), intent(out), dimension(4,nLambda,nDepth) :: RFt, RFp, RFh, RFv, RFg, RFf, RFmic
	real(c_float), intent(out), dimension(4,nLambda) :: RFmac

	real*4 stok(kld4)
    real*4 rt(kldt4),rp(kldt4),rh(kldt4),rv(kldt4)
    real*4 rg(kldt4),rf(kldt4),rm(kldt4), rmac(kld4)
    integer ist(4),i,k,ntot, j, l, itau
	integer ntl,nlin(kl),npas(kl),nble(kl)
	real*4 dlamda(kld)
	character*100 Stokesfilename
	integer*4 mnodos(18), ntau
	real*4 tau(kt),t(kt),pe(kt),pg(kt),z(kt),ro(kt)
	real*4 atmosmodel(kt8), pesostray
	real*4 voffset,xmu
	common/Malla/ntl,nlin,npas,nble,dlamda  !common para StokesFRsub
    common/OutputStokes/Stokesfilename

    common/Atmosmodel/atmosmodel,ntau !common para StokesFRsub
	common/numeronodos/mnodos         !para StokesFRsub
    common/offset/voffset             !para StokesFRsub
    common/anguloheliocent/xmu        !para StokesFRsub

	    ntau = nDepth

! offset de velocidad para perturbaciones relativas necesitamos que la velocidad sea siempre positiva
		voffset=-15.e5    !cm/s
	    xmu=1.            !coseno del angulo heliocentrico

! Put the model in vectorized form
		atmosmodel(8*ntau+1) = macroturbulence
		atmosmodel(8*ntau+2) = filling
		pesostray = stray
		do i = 1, ntau
			do j = 0, 7
				atmosmodel(i+j*ntau) = model(j+1,i)
			enddo
			tau(i) = atmosmodel(i)
			t(i) = atmosmodel(i+ntau)
			pe(i) = atmosmodel(i+2*ntau)
		enddo

! pasamos los angulos a radianes
		call taulinea(0,1.,1,0.,atmosmodel,ntau)

! definimos los nodos en todos los puntos (excepto para ls presion elctronica)
		do i=1,8
        	mnodos(i)=ntau
		end do
    	mnodos(2)=0

! Calculate hydrostatic equilibrium if Pe is not known
    	if (minval(model(3,:)) == -1) then

    		call equisubmu(ntau,tau,t,pe,pg,z,ro)

        	do i=1,ntau
            	atmosmodel(i+2*ntau)=pe(i)
        	end do
        endif

		call StokesFRsub(stok,rt,rp,rh,rv,rg,rf,rm,rmac)

! contamos el numero de puntos
		ntot=0
		do i=1,ntl
        	do j=1,npas(i)
	      		ntot=ntot+1
	    	end do
		end do

! Output Stokes parameters
		stokes(1,:) = dlamda(1:ntot)
		stokes(2,:) = stok(1:ntot)
		stokes(3,:) = stok(ntot+1:2*ntot)
		stokes(4,:) = stok(2*ntot+1:3*ntot)
		stokes(5,:) = stok(3*ntot+1:4*ntot)

! Output response functions
		do itau = 1, ntau
			RFt(1,:,itau) = rt(1+4*ntot*(itau-1):ntot+4*ntot*(itau-1))
			RFt(2,:,itau) = rt(ntot+1+4*ntot*(itau-1):2*ntot+4*ntot*(itau-1))
			RFt(3,:,itau) = rt(2*ntot+1+4*ntot*(itau-1):3*ntot+4*ntot*(itau-1))
			RFt(4,:,itau) = rt(3*ntot+1+4*ntot*(itau-1):4*ntot+4*ntot*(itau-1))

			RFp(1,:,itau) = rp(1+4*ntot*(itau-1):ntot+4*ntot*(itau-1))
			RFp(2,:,itau) = rp(ntot+1+4*ntot*(itau-1):2*ntot+4*ntot*(itau-1))
			RFp(3,:,itau) = rp(2*ntot+1+4*ntot*(itau-1):3*ntot+4*ntot*(itau-1))
			RFp(4,:,itau) = rp(3*ntot+1+4*ntot*(itau-1):4*ntot+4*ntot*(itau-1))

			RFh(1,:,itau) = rh(1+4*ntot*(itau-1):ntot+4*ntot*(itau-1))
			RFh(2,:,itau) = rh(ntot+1+4*ntot*(itau-1):2*ntot+4*ntot*(itau-1))
			RFh(3,:,itau) = rh(2*ntot+1+4*ntot*(itau-1):3*ntot+4*ntot*(itau-1))
			RFh(4,:,itau) = rh(3*ntot+1+4*ntot*(itau-1):4*ntot+4*ntot*(itau-1))

			RFv(1,:,itau) = rv(1+4*ntot*(itau-1):ntot+4*ntot*(itau-1))
			RFv(2,:,itau) = rv(ntot+1+4*ntot*(itau-1):2*ntot+4*ntot*(itau-1))
			RFv(3,:,itau) = rv(2*ntot+1+4*ntot*(itau-1):3*ntot+4*ntot*(itau-1))
			RFv(4,:,itau) = rv(3*ntot+1+4*ntot*(itau-1):4*ntot+4*ntot*(itau-1))

			RFg(1,:,itau) = rg(1+4*ntot*(itau-1):ntot+4*ntot*(itau-1))
			RFg(2,:,itau) = rg(ntot+1+4*ntot*(itau-1):2*ntot+4*ntot*(itau-1))
			RFg(3,:,itau) = rg(2*ntot+1+4*ntot*(itau-1):3*ntot+4*ntot*(itau-1))
			RFg(4,:,itau) = rg(3*ntot+1+4*ntot*(itau-1):4*ntot+4*ntot*(itau-1))

			RFf(1,:,itau) = rf(1+4*ntot*(itau-1):ntot+4*ntot*(itau-1))
			RFf(2,:,itau) = rf(ntot+1+4*ntot*(itau-1):2*ntot+4*ntot*(itau-1))
			RFf(3,:,itau) = rf(2*ntot+1+4*ntot*(itau-1):3*ntot+4*ntot*(itau-1))
			RFf(4,:,itau) = rf(3*ntot+1+4*ntot*(itau-1):4*ntot+4*ntot*(itau-1))

			RFmic(1,:,itau) = rm(1+4*ntot*(itau-1):ntot+4*ntot*(itau-1))
			RFmic(2,:,itau) = rm(ntot+1+4*ntot*(itau-1):2*ntot+4*ntot*(itau-1))
			RFmic(3,:,itau) = rm(2*ntot+1+4*ntot*(itau-1):3*ntot+4*ntot*(itau-1))
			RFmic(4,:,itau) = rm(3*ntot+1+4*ntot*(itau-1):4*ntot+4*ntot*(itau-1))

		enddo

		RFmac(1,:) = rmac(1:ntot)
		RFmac(2,:) = rmac(ntot+1:2*ntot)
		RFmac(3,:) = rmac(2*ntot+1:3*ntot)
		RFmac(4,:) = rmac(3*ntot+1:4*ntot)

	end subroutine c_synthrf

end module sirMod