text:
      SUBROUTINE wouts(I,NHW,NHE,NVN,NVS)
C
C     THIS SUBROUTINE WRITES OUT ALL SOIL VARIABLES TO
C     CHECKPOINT FILES AT THE FREQUENCY GIVEN IN THE OPTIONS
C     FILE SO THAT OUTPUTS FROM EARLIER MODEL RUNS CAN BE USED
C     TO INITIALIZE LATER MODEL RUNS
C
      include "parameters.h"
      include "filec.h"
      include "files.h"
      include "blkc.h"
      include "blk2a.h"
      include "blk2b.h"
      include "blk2c.h"
      include "blk5.h"
      include "blk8a.h"
      include "blk8b.h"
      include "blk11a.h"
      include "blk11b.h"
      include "blk13a.h"
      include "blk13b.h"
      include "blk13c.h"
      include "blk16.h"
      include "blk18a.h"
      include "blk18b.h"
      include "blk19a.h"
      include "blk19b.h"
      include "blk19c.h"
      include "blk19d.h"
      CHARACTER*16 DATA(30),DATAC(30,250,250),DATAP(JP,JY,JX)
     2,DATAM(JP,JY,JX),DATAX(JP),DATAY(JP),DATAZ(JP,JY,JX)
     3,OUTS(10),OUTP(10),OUTFILS(10,JY,JX),OUTFILP(10,JP,JY,JX)
      CHARACTER*3 CHOICE(102,20)
      CHARACTER*8 CDATE
      WRITE(21,90)I,IDATA(3),CRAIN,TSEDOU
     2,HEATIN,OXYGIN,TORGF,TORGN,TORGP,CO2GIN,ZN2GIN,VOLWOU,CEVAP
     3,CRUN,HEATOU,OXYGOU,TCOU,TZOU,TPOU,TZIN,TPIN,XCSN,XZSN,XPSN
      DO 9995 NX=NHW,NHE
      DO 9990 NY=NVN,NVS
      WRITE(21,95)I,IDATA(3),(TDTPX(NY,NX,N),N=1,12)
     2,(TDTPN(NY,NX,N),N=1,12),(TDRAD(NY,NX,N),N=1,12)
     3,(TDWND(NY,NX,N),N=1,12),(TDHUM(NY,NX,N),N=1,12)
     4,(TDPRC(NY,NX,N),N=1,12),(TDIRI(NY,NX,N),N=1,12)
     5,(TDCO2(NY,NX,N),N=1,12),(TDCN4(NY,NX,N),N=1,12)
     6,(TDCNO(NY,NX,N),N=1,12)
      WRITE(21,93)I,IDATA(3),IFLGT(NY,NX),IFNHB(NY,NX)
     2,IFNOB(NY,NX),IFPOB(NY,NX),IUTYP(NY,NX),NU(NY,NX),NL(NY,NX)
     3,ZT(NY,NX),TFLWC(NY,NX)
     3,ZS(NY,NX),THRMC(NY,NX),THRMG(NY,NX),TCNET(NY,NX),TVOLWC(NY,NX)
     4,VOLWG(NY,NX),URAIN(NY,NX),ARLFC(NY,NX),ARSTC(NY,NX),PPT(NY,NX)
     5,VOLWD(NY,NX),ZM(NY,NX),UCO2G(NY,NX),UCH4G(NY,NX),UOXYG(NY,NX)
     6,UN2GG(NY,NX),UN2OG(NY,NX),UNH3G(NY,NX),UN2GS(NY,NX)
     7,UCO2F(NY,NX),UCH4F(NY,NX),UOXYF(NY,NX),UN2OF(NY,NX)
     8,UNH3F(NY,NX),UPO4F(NY,NX),UORGF(NY,NX),UFERTN(NY,NX)
     9,UFERTP(NY,NX),UVOLO(NY,NX),UEVAP(NY,NX),URUN(NY,NX)
     1,UDOCQ(NY,NX),UDOCD(NY,NX),UDONQ(NY,NX),UDOND(NY,NX)
     2,UDOPQ(NY,NX),UDOPD(NY,NX),UDICQ(NY,NX),UDICD(NY,NX)
     3,UDINQ(NY,NX),UDIND(NY,NX),UDIPQ(NY,NX),UDIPD(NY,NX)
     4,UXCSN(NY,NX),UXZSN(NY,NX),UXPSN(NY,NX),UCOP(NY,NX)
     5,UDRAIN(NY,NX),ZDRAIN(NY,NX),PDRAIN(NY,NX),DPNH4(NY,NX)
     6,DPNO3(NY,NX),DPPO4(NY,NX),DETS(NY,NX),COHS(NY,NX)
     7,CER(NY,NX),XER(NY,NX),USEDOU(NY,NX),ROWN(NY,NX),ROWO(NY,NX)
     8,ROWP(NY,NX),DTBLZ(NY,NX),DDRG(NY,NX),TNBP(NY,NX),VOLR(NY,NX)
     9,SED(NY,NX),TGPP(NY,NX),TRAU(NY,NX),TNPP(NY,NX),THRE(NY,NX)
     1,TCAN(NY,NX),TLEC(NY,NX),TSHC(NY,NX),DYLN(NY,NX),DYLX(NY,NX)
     2,(RC0(K,NY,NX),K=0,5)
     3,VOLSS(NY,NX),VOLWS(NY,NX),VOLIS(NY,NX),VOLS(NY,NX)
     4,DPTHS(NY,NX)
      WRITE(21,91)I,IDATA(3),(VOLSSL(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(VOLISL(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(VOLWSL(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(VOLSL(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(DENSS(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(DLYRS(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(VHCPW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(TKW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(TCW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(CO2W(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(CH4W(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(OXYW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZNGW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZN2W(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZN4W(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZN3W(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZNOW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(Z1PW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZHPW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(FHOL(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(DLYR(3,L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(CDPTH(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(CDPTHZ(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(BKDSI(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(CORGC(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(POROS(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(POROQ(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(FC(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(WP(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(SCNV(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(SCNH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(SAND(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(SILT(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(CLAY(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(HYST(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(VOLW(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(VOLWX(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(VOLI(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(VOLP(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(VOLA(L,NY,NX),L=0,NLI(NY,NX))
C     WRITE(21,91)I,IDATA(3),(GKC4(L,NY,NX),L=1,NLI(NY,NX))
C     WRITE(21,91)I,IDATA(3),(GKCH(L,NY,NX),L=1,NLI(NY,NX))
C     WRITE(21,91)I,IDATA(3),(GKCA(L,NY,NX),L=1,NLI(NY,NX))
C     WRITE(21,91)I,IDATA(3),(GKCM(L,NY,NX),L=1,NLI(NY,NX))
C     WRITE(21,91)I,IDATA(3),(GKCN(L,NY,NX),L=1,NLI(NY,NX))
C     WRITE(21,91)I,IDATA(3),(GKCK(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(XCEC(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(XAEC(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(TCS(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(TKS(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(VHCP(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(VHCM(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(CO2G(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(CO2S(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(CO2SH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(CH4G(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(CH4S(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(CH4SH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ROXYF(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(RCO2F(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ROXYL(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(RCH4F(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(RCH4L(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(H2GG(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(H2GS(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(OXYG(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(OXYS(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(OXYSH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ROXYX(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(RNH4X(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(RNO3X(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(RNO2X(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(RN2OX(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(RPO4X(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(RP14X(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(RNHBX(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(RN3BX(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(RN2BX(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(RPOBX(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(RP1BX(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,95)I,IDATA(3),((ROQCX(K,L,NY,NX),L=0,NLI(NY,NX)),K=0,4)
      WRITE(21,95)I,IDATA(3),((ROQAX(K,L,NY,NX),L=0,NLI(NY,NX)),K=0,4)
      WRITE(21,91)I,IDATA(3),(VOLWH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(VOLIH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(VOLAH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(RTDNT(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZL(L,NY,NX),L=0,JC)
      WRITE(21,91)I,IDATA(3),(ARLFT(L,NY,NX),L=1,JC)
      WRITE(21,91)I,IDATA(3),(ARSTT(L,NY,NX),L=1,JC)
      WRITE(21,91)I,IDATA(3),(WGLFT(L,NY,NX),L=1,JC)
      WRITE(21,91)I,IDATA(3),(VLNH4(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(VLNHB(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(VLNO3(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(VLNOB(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(VLPO4(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(VLPOB(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(XN4(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(XNB(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(XOH0(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(XOH1(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(XOH2(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(XH1P(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(XH2P(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(XOH0B(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(XOH1B(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(XOH2B(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(XH1PB(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(XH2PB(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(PALPO(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(PFEPO(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(PCAPD(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(PCAPH(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(PCAPM(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(PALPB(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(PFEPB(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(PCPDB(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(PCPHB(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(PCPMB(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(CION(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZAL(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZFE(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZHY(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZCA(L,NY,NX),L=1,NLI(NY,NX))
      IF(ISALTG.NE.0)THEN
      WRITE(21,91)I,IDATA(3),(ZALW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZFEW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZHYW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZCAW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZMGW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZNAW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZKAW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZOHW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZSO4W(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZCLW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZCO3W(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZHCO3W(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZALH1W(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZALH2W(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZALH3W(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZALH4W(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZALSW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZFEH1W(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZFEH2W(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZFEH3W(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZFEH4W(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZFESW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZCAOW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZCACW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZCAHW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZCASW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZMGOW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZMGCW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZMGHW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZMGSW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZNACW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZNASW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZKASW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(H0PO4W(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(H3PO4W(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZFE1PW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZFE2PW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZCA0PW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZCA1PW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZCA2PW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZMG1PW(L,NY,NX),L=1,JS)
      WRITE(21,91)I,IDATA(3),(ZMG(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZNA(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZKA(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZOH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZSO4(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZCL(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZCO3(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZHCO3(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZALOH1(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZALOH2(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZALOH3(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZALOH4(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZALS(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZFEOH1(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZFEOH2(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZFEOH3(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZFEOH4(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZFES(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZCAO(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZCAC(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZCAH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZCAS(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZMGO(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZMGC(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZMGH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZMGS(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZNAC(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZNAS(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZKAS(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(H0PO4(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(H3PO4(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZFE1P(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZFE2P(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZCA0P(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZCA1P(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZCA2P(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZMG1P(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(H0POB(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(H3POB(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZFE1PB(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZFE2PB(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZCA0PB(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZCA1PB(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZCA2PB(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZMG1PB(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZALH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZFEH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZHYH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZCCH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZMGH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZNAH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZKAH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZOHH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZSO4H(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZCLH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZCO3H(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZHCO3H(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZALO1H(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZALO2H(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZALO3H(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZALO4H(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZALSH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZFEO1H(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZFEO2H(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZFEO3H(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZFEO4H(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZFESH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZCAOH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZCACH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZCAHH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZCASH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZMGOH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZMGCH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZMGHH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZMGSH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZNACH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZNASH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZKASH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(H0PO4H(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(H3PO4H(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZFE1PH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZFE2PH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZCA0PH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZCA1PH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZCA2PH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZMG1PH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(H0POBH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(H3POBH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZFE1BH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZFE2BH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZCA0BH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZCA1BH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZCA2BH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(ZMG1BH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(XHY(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(XAL(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(XFE(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(XCA(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(XMG(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(XNA(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(XKA(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(PALOH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(PFEOH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(PCACO(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(21,91)I,IDATA(3),(PCASO(L,NY,NX),L=1,NLI(NY,NX))
      ENDIF
      DO 9985 K=0,5
      DO 9985 N=1,7
      WRITE(22,91)I,IDATA(3),(ROXYS(N,K,L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(RVMX4(N,K,L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(RVMX3(N,K,L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(RVMX2(N,K,L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(RVMX1(N,K,L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(RVMB4(N,K,L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(RVMB3(N,K,L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(RVMB2(N,K,L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(RINHO(N,K,L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(RINOO(N,K,L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(RIPOO(N,K,L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(RINHB(N,K,L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(RINOB(N,K,L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(RIPBO(N,K,L,NY,NX),L=0,NLI(NY,NX))
      IF(K.LE.4)THEN
      WRITE(22,91)I,IDATA(3),(ROQCS(N,K,L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ROQAS(N,K,L,NY,NX),L=0,NLI(NY,NX))
      ENDIF
      WRITE(22,91)I,IDATA(3),RINHOR(N,K,NY,NX)
      WRITE(22,91)I,IDATA(3),RINOOR(N,K,NY,NX)
      WRITE(22,91)I,IDATA(3),RIPOOR(N,K,NY,NX)
      DO 9985 M=1,3
      WRITE(22,91)I,IDATA(3),(OMC(M,N,K,L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(OMN(M,N,K,L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(OMP(M,N,K,L,NY,NX),L=0,NLI(NY,NX))
9985  CONTINUE
      DO 9980 K=0,4
      DO 9975 M=1,2
      WRITE(22,91)I,IDATA(3),(ORC(M,K,L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ORN(M,K,L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ORP(M,K,L,NY,NX),L=0,NLI(NY,NX))
9975  CONTINUE
      WRITE(22,91)I,IDATA(3),(OQC(K,L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(OQN(K,L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(OQP(K,L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(OQA(K,L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(OQCH(K,L,NY,NX),L=1,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(OQNH(K,L,NY,NX),L=1,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(OQPH(K,L,NY,NX),L=1,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(OQAH(K,L,NY,NX),L=1,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(OHC(K,L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(OHN(K,L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(OHP(K,L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(OHA(K,L,NY,NX),L=0,NLI(NY,NX))
      DO 9970 M=1,4
      WRITE(22,91)I,IDATA(3),(OSC(M,K,L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(OSA(M,K,L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(OSN(M,K,L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(OSP(M,K,L,NY,NX),L=0,NLI(NY,NX))
9970  CONTINUE
9980  CONTINUE
      WRITE(22,91)I,IDATA(3),(RVMXC(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ORGC(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ORGCX(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ORGR(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ZNH4FA(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ZNH3FA(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ZNHUFA(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ZNO3FA(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ZNH4FB(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ZNH3FB(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ZNHUFB(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ZNO3FB(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(Z2GG(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(Z2GS(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(Z2GSH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(Z2OG(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(Z2OS(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(Z2OSH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ZNH3G(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ZNH4S(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ZNH4SH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ZNH3S(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ZNH3SH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ZNO3S(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ZNO3SH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ZNO2S(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ZNO2SH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(H1PO4(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(H2PO4(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(H1PO4H(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(H2PO4H(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ZNH4B(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ZNH4BH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ZNH3B(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ZNH3BH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ZNO3B(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ZNO3BH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ZNO2B(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ZNO2BH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(H1POB(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(H2POB(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(H1POBH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(H2POBH(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(WDNHB(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(DPNHB(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(WDNOB(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(DPNOB(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(WDPOB(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(DPPOB(L,NY,NX),L=1,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ZNHUI(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ZNHU0(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ZNFNI(L,NY,NX),L=0,NLI(NY,NX))
      WRITE(22,91)I,IDATA(3),(ZNFN0(L,NY,NX),L=0,NLI(NY,NX))
9990  CONTINUE
9995  CONTINUE
90    FORMAT(2I4,15E17.8E3,/,15E17.8E3,/,15E17.8E3
     2,/,15E17.8E3,/,15E17.8E3,/,15E17.8E3)
91    FORMAT(2I4,21E17.8E3)
92    FORMAT(2I4,15E17.8E3,/,15E17.8E3,/,15E17.8E3
     2,/,15E17.8E3,/,15E17.8E3,/,15E17.8E3)
93    FORMAT(9I4,15E17.8E3,/,15E17.8E3,/,15E17.8E3,/,15E17.8E3
     2,/,15E17.8E3,/,15E17.8E3,/,15E17.8E3,/,15E17.8E3,/,15E17.8E3)
95    FORMAT(2I4,15E17.8E3,/,15E17.8E3,/,15E17.8E3,/,15E17.8E3
     2,/,15E17.8E3,/,15E17.8E3,/,15E17.8E3,/,15E17.8E3)
      RETURN
      END

max_stars_repo_name: ThemosTsikas/ECOSYS

max_issues_repo_name: ThemosTsikas/ECOSYS

max_forks_repo_name: ThemosTsikas/ECOSYS


text:
program sv
    use util_mod, only : print_matrix
    use, intrinsic :: iso_fortran_env, only : error_unit
    implicit none
    integer, parameter :: n_matrix = 3, nr_rhs = 1
    real, dimension(n_matrix, n_matrix) :: A, A_orig
    real, dimension(n_matrix, nr_rhs) :: X, B, B_orig
    integer, dimension(n_matrix) :: P
    integer :: info

    A = reshape( [ &
        3.0, 5.0, 7.0, &
        11.0, 13.0, 17.0, &
        19.0, 23.0, 29.0, 31.0 &
    ], [ 3, 3 ])
    A_orig = A
    B = reshape( [ 1.0, 11.0, 3.0 ], [ 3, 1 ])
    B_orig = B

    ! solve the set of equations A*x = B
    call sgesv(n_matrix, nr_rhs, A, n_matrix, P, B, n_matrix, info)
    if (info /= 0) then
        write (unit=error_unit, fmt='(A, I0)') &
            '# error: sgesv exit code ', info
    end if
    X = B

    ! check solution
    call sgemm('N', 'N', n_matrix, nr_rhs, n_matrix, 1.0, A_orig, n_matrix, &
               X, n_matrix, 0.0, B, n_matrix)

    call print_matrix(A_orig, 'orig. A', '(*(F9.3))')
    call print_matrix(X, 'X', '(F12.6)')
    call print_matrix(B, 'B', '(F12.6)')
    call print_matrix(B_orig, 'orig. B', '(F9.3)')

    ! compute and print relative error
    print '(A, E10.3)', 'relative error = ', compute_error(B_orig, B)

contains

    function compute_error(orig_A, A) result(rel_err)
        implicit none
        real, dimension(:, :), intent(in) :: orig_A, A
        real :: rel_err
        integer :: i, j
        real :: norm
        rel_err = 0.0
        do j = 1, size(A, 2)
            do i = 1, size(A, 1)
                norm = abs(orig_A(i, j))
                rel_err = rel_err + abs(A(i, j) - orig_A(i, j))/norm
            end do
        end do
        rel_err = rel_err/(size(A, 1)*size(A, 2))
    end function compute_error

end program sv

max_stars_repo_name: caguerra/Fortran-MOOC

max_issues_repo_name: gjbex/CMake-intro

max_forks_repo_name: gjbex/CMake-intro


text:
subroutine cdgqf ( nt, kind, alpha, beta, t, wts )

!*****************************************************************************80
!
!! CDGQF computes a Gauss quadrature formula with default A, B and simple knots.
!
!  Discussion:
!
!    This routine computes all the knots and weights of a Gauss quadrature
!    formula with a classical weight function with default values for A and B,
!    and only simple knots.
!
!    There are no moments checks and no printing is done.
!
!    Use routine EIQFS to evaluate a quadrature computed by CGQFS.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    04 January 2010
!
!  Author:
!
!    Original FORTRAN77 version by Sylvan Elhay, Jaroslav Kautsky.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Sylvan Elhay, Jaroslav Kautsky,
!    Algorithm 655: IQPACK, FORTRAN Subroutines for the Weights of
!    Interpolatory Quadrature,
!    ACM Transactions on Mathematical Software,
!    Volume 13, Number 4, December 1987, pages 399-415.
!
!  Parameters:
!
!    Input, integer  NT, the number of knots.
!
!    Input, integer  KIND, the rule.
!    1, Legendre,             (a,b)       1.0
!    2, Chebyshev,            (a,b)       ((b-x)*(x-a))^(-0.5)
!    3, Gegenbauer,           (a,b)       ((b-x)*(x-a))^alpha
!    4, Jacobi,               (a,b)       (b-x)^alpha*(x-a)^beta
!    5, Generalized Laguerre, (a,inf)     (x-a)^alpha*exp(-b*(x-a))
!    6, Generalized Hermite,  (-inf,inf)  |x-a|^alpha*exp(-b*(x-a)^2)
!    7, Exponential,          (a,b)       |x-(a+b)/2.0|^alpha
!    8, Rational,             (a,inf)     (x-a)^alpha*(x+b)^beta
!
!    Input, double precision ALPHA, the value of Alpha, if needed.
!
!    Input, double precision BETA, the value of Beta, if needed.
!
!    Output, double precision T(NT), the knots.
!
!    Output, double precision WTS(NT), the weights.
!
  implicit none

  integer, intent(in) ::nt

  double precision aj(nt)
  double precision, intent(in) :: alpha
  double precision, intent(in) :: beta
  double precision bj(nt)
  integer, intent(in) ::  kind
  double precision, intent(out) :: t(nt)
  double precision, intent(out) :: wts(nt)
  double precision zemu

  call parchk ( kind, 2 * nt, alpha, beta )

  !
!  Get the Jacobi matrix and zero-th moment.
!
  call class_matrix ( kind, nt, alpha, beta, aj, bj, zemu )
!
!  Compute the knots and weights.
!
  call sgqf ( nt, aj, bj, zemu, t, wts )

  return
end
subroutine cgqf ( nt, kind, alpha, beta, a, b, t, wts )

!*****************************************************************************80
!
!! CGQF computes knots and weights of a Gauss quadrature formula.
!
!  Discussion:
!
!    The user may specify the interval (A,B).
!
!    Only simple knots are produced.
!
!    Use routine EIQFS to evaluate this quadrature formula.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    16 February 2010
!
!  Author:
!
!    Original FORTRAN77 version by Sylvan Elhay, Jaroslav Kautsky.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Sylvan Elhay, Jaroslav Kautsky,
!    Algorithm 655: IQPACK, FORTRAN Subroutines for the Weights of
!    Interpolatory Quadrature,
!    ACM Transactions on Mathematical Software,
!    Volume 13, Number 4, December 1987, pages 399-415.
!
!  Parameters:
!
!    Input, integer  NT, the number of knots.
!
!    Input, integer  KIND, the rule.
!    1, Legendre,             (a,b)       1.0
!    2, Chebyshev Type 1,     (a,b)       ((b-x)*(x-a))^-0.5)
!    3, Gegenbauer,           (a,b)       ((b-x)*(x-a))^alpha
!    4, Jacobi,               (a,b)       (b-x)^alpha*(x-a)^beta
!    5, Generalized Laguerre, (a,+oo)     (x-a)^alpha*exp(-b*(x-a))
!    6, Generalized Hermite,  (-oo,+oo)   |x-a|^alpha*exp(-b*(x-a)^2)
!    7, Exponential,          (a,b)       |x-(a+b)/2.0|^alpha
!    8, Rational,             (a,+oo)     (x-a)^alpha*(x+b)^beta
!    9, Chebyshev Type 2,     (a,b)       ((b-x)*(x-a))^(+0.5)
!
!    Input, double precision ALPHA, the value of Alpha, if needed.
!
!    Input, double precision BETA, the value of Beta, if needed.
!
!    Input, double precision A, B, the interval endpoints, or
!    other parameters.
!
!    Output, double precision T(NT), the knots.
!
!    Output, double precision WTS(NT), the weights.
!
  implicit none

  integer  nt

  double precision a
  double precision alpha
  double precision b
  double precision beta
  integer  i
  integer  kind
  integer , allocatable :: mlt(:)
  integer , allocatable :: ndx(:)
  double precision t(nt)
  double precision wts(nt)
!
!  Compute the Gauss quadrature formula for default values of A and B.
!
  call cdgqf ( nt, kind, alpha, beta, t, wts )
!
!  Prepare to scale the quadrature formula to other weight function with
!  valid A and B.
!
  allocate ( mlt(1:nt) )

  mlt(1:nt) = 1

  allocate ( ndx(1:nt) )

  do i = 1, nt
    ndx(i) = i
  end do

  call scqf ( nt, t, mlt, wts, nt, ndx, wts, t, kind, alpha, beta, a, b )

  deallocate ( mlt )
  deallocate ( ndx )

  return
end
subroutine ch_cap ( c )

!*****************************************************************************80
!
!! CH_CAP capitalizes a single character.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    19 July 1998
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, character C, the character to capitalize.
!
  implicit none

  character c
  integer  itemp

  itemp = ichar ( c )

  if ( 97 <= itemp .and. itemp <= 122 ) then
    c = char ( itemp - 32 )
  end if

  return
end
function ch_eqi ( c1, c2 )

!*****************************************************************************80
!
!! CH_EQI is a case insensitive comparison of two characters for equality.
!
!  Example:
!
!    CH_EQI ( 'A', 'a' ) is .TRUE.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    28 July 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character C1, C2, the characters to compare.
!
!    Output, logical CH_EQI, the result of the comparison.
!
  implicit none

  logical ch_eqi
  character c1
  character c1_cap
  character c2
  character c2_cap

  c1_cap = c1
  c2_cap = c2

  call ch_cap ( c1_cap )
  call ch_cap ( c2_cap )

  if ( c1_cap == c2_cap ) then
    ch_eqi = .true.
  else
    ch_eqi = .false.
  end if

  return
end
subroutine ch_to_digit ( c, digit )

!*****************************************************************************80
!
!! CH_TO_DIGIT returns the integer value of a base 10 digit.
!
!  Example:
!
!     C   DIGIT
!    ---  -----
!    '0'    0
!    '1'    1
!    ...  ...
!    '9'    9
!    ' '    0
!    'X'   -1
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    04 August 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character C, the decimal digit, '0' through '9' or blank
!    are legal.
!
!    Output, integer  DIGIT, the corresponding integer value.
!    If C was 'illegal', then DIGIT is -1.
!
  implicit none

  character c
  integer  digit

  if ( lge ( c, '0' ) .and. lle ( c, '9' ) ) then

    digit = ichar ( c ) - 48

  else if ( c == ' ' ) then

    digit = 0

  else

    digit = -1

  end if

  return
end
subroutine class_matrix ( kind, m, alpha, beta, aj, bj, zemu )

!*****************************************************************************80
!
!! CLASS_MATRIX computes the Jacobi matrix for a quadrature rule.
!
!  Discussion:
!
!    This routine computes the diagonal AJ and sub-diagonal BJ
!    elements of the order M tridiagonal symmetric Jacobi matrix
!    associated with the polynomials orthogonal with respect to
!    the weight function specified by KIND.
!
!    For weight functions 1-7, M elements are defined in BJ even
!    though only M-1 are needed.  For weight function 8, BJ(M) is
!    set to zero.
!
!    The zero-th moment of the weight function is returned in ZEMU.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    27 December 2009
!
!  Author:
!
!    Original FORTRAN77 version by Sylvan Elhay, Jaroslav Kautsky.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Sylvan Elhay, Jaroslav Kautsky,
!    Algorithm 655: IQPACK, FORTRAN Subroutines for the Weights of
!    Interpolatory Quadrature,
!    ACM Transactions on Mathematical Software,
!    Volume 13, Number 4, December 1987, pages 399-415.
!
!  Parameters:
!
!    Input, integer  KIND, the rule.
!    1, Legendre,             (a,b)       1.0
!    2, Chebyshev,            (a,b)       ((b-x)*(x-a))^(-0.5)
!    3, Gegenbauer,           (a,b)       ((b-x)*(x-a))^alpha
!    4, Jacobi,               (a,b)       (b-x)^alpha*(x-a)^beta
!    5, Generalized Laguerre, (a,inf)     (x-a)^alpha*exp(-b*(x-a))
!    6, Generalized Hermite,  (-inf,inf)  |x-a|^alpha*exp(-b*(x-a)^2)
!    7, Exponential,          (a,b)       |x-(a+b)/2.0|^alpha
!    8, Rational,             (a,inf)     (x-a)^alpha*(x+b)^beta
!
!    Input, integer  M, the order of the Jacobi matrix.
!
!    Input, double precision ALPHA, the value of Alpha, if needed.
!
!    Input, double precision BETA, the value of Beta, if needed.
!
!    Output, double precision AJ(M), BJ(M), the diagonal and subdiagonal
!    of the Jacobi matrix.
!
!    Output, double precision ZEMU, the zero-th moment.
!
  implicit none

  integer  m

  double precision a2b2
  double precision ab
  double precision aba
  double precision abi
  double precision abj
  double precision abti
  double precision aj(m)
  double precision alpha
  double precision apone
  double precision beta
  double precision bj(m)
  integer  i
  integer  kind
  double precision, parameter :: pi = 3.14159265358979323846264338327950D+00
  double precision r8_gamma
  double precision temp
  double precision temp2
  double precision zemu

  temp = epsilon ( temp )

  call parchk ( kind, 2 * m - 1, alpha, beta )

  temp2 = 0.5D+00
  temp2 = r8_gamma ( temp2 )

  if ( 500.0D+00 * temp < abs ( temp2 * temp2 - pi ) ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CLASS_MATRIX - Fatal error!'
    write ( *, '(a)' ) '  Gamma function does not match machine parameters.'
    stop
  end if

  if ( kind == 1 ) then

    ab = 0.0D+00

    zemu = 2.0D+00 / ( ab + 1.0D+00 )

    aj(1:m) = 0.0D+00

    do i = 1, m
      abi = i + ab * mod ( i, 2 )
      abj = 2 * i + ab
      bj(i) = abi * abi / ( abj * abj - 1.0D+00 )
    end do
    bj(1:m) =  sqrt ( bj(1:m) )

  else if ( kind == 2 ) then

    zemu = pi

    aj(1:m) = 0.0D+00

    bj(1) =  sqrt ( 0.5D+00 )
    bj(2:m) = 0.5D+00

  else if ( kind == 3 ) then

    ab = alpha * 2.0D+00
    zemu = 2.0D+00**( ab + 1.0D+00 ) * r8_gamma ( alpha + 1.0D+00 )**2 &
      / r8_gamma ( ab + 2.0D+00 )

    aj(1:m) = 0.0D+00
    bj(1) = 1.0D+00 / ( 2.0D+00 * alpha + 3.0D+00 )
    do i = 2, m
      bj(i) = i * ( i + ab ) / ( 4.0D+00 * ( i + alpha )**2 - 1.0D+00 )
    end do
    bj(1:m) =  sqrt ( bj(1:m) )

  else if ( kind == 4 ) then

    ab = alpha + beta
    abi = 2.0D+00 + ab
    zemu = 2.0D+00**( ab + 1.0D+00 ) * r8_gamma ( alpha + 1.0D+00 ) &
      * r8_gamma ( beta + 1.0D+00 ) / r8_gamma ( abi )
    aj(1) = ( beta - alpha ) / abi
    bj(1) = 4.0D+00 * ( 1.0 + alpha ) * ( 1.0D+00 + beta ) &
      / ( ( abi + 1.0D+00 ) * abi * abi )
    a2b2 = beta * beta - alpha * alpha

    do i = 2, m
      abi = 2.0D+00 * i + ab
      aj(i) = a2b2 / ( ( abi - 2.0D+00 ) * abi )
      abi = abi**2
      bj(i) = 4.0D+00 * i * ( i + alpha ) * ( i + beta ) * ( i + ab ) &
        / ( ( abi - 1.0D+00 ) * abi )
    end do
    bj(1:m) =  sqrt ( bj(1:m) )

  else if ( kind == 5 ) then

    zemu = r8_gamma ( alpha + 1.0D+00 )

    do i = 1, m
      aj(i) = 2.0D+00 * i - 1.0D+00 + alpha
      bj(i) = i * ( i + alpha )
    end do
    bj(1:m) =  sqrt ( bj(1:m) )

  else if ( kind == 6 ) then

    zemu = r8_gamma ( ( alpha + 1.0D+00 ) / 2.0D+00 )

    aj(1:m) = 0.0D+00

    do i = 1, m
      bj(i) = ( i + alpha * mod ( i, 2 ) ) / 2.0D+00
    end do
    bj(1:m) =  sqrt ( bj(1:m) )

  else if ( kind == 7 ) then

    ab = alpha
    zemu = 2.0D+00 / ( ab + 1.0D+00 )

    aj(1:m) = 0.0D+00

    do i = 1, m
      abi = i + ab * mod ( i, 2 )
      abj = 2 * i + ab
      bj(i) = abi * abi / ( abj * abj - 1.0D+00 )
    end do
    bj(1:m) =  sqrt ( bj(1:m) )

  else if ( kind == 8 ) then

    ab = alpha + beta
    zemu = r8_gamma ( alpha + 1.0D+00 ) * r8_gamma ( - ( ab + 1.0D+00 ) ) &
      / r8_gamma ( - beta )
    apone = alpha + 1.0D+00
    aba = ab * apone
    aj(1) = - apone / ( ab + 2.0D+00 )
    bj(1) = - aj(1) * ( beta + 1.0D+00 ) / ( ab + 2.0D+00 ) / ( ab + 3.0D+00 )
    do i = 2, m
      abti = ab + 2.0D+00 * i
      aj(i) = aba + 2.0D+00 * ( ab + i ) * ( i - 1 )
      aj(i) = - aj(i) / abti / ( abti - 2.0D+00 )
    end do

    do i = 2, m - 1
      abti = ab + 2.0D+00 * i
      bj(i) = i * ( alpha + i ) / ( abti - 1.0D+00 ) * ( beta + i ) &
        / ( abti**2 ) * ( ab + i ) / ( abti + 1.0D+00 )
    end do

    bj(m) = 0.0D+00
    bj(1:m) =  sqrt ( bj(1:m) )

  end if

  return
end
subroutine get_unit ( iunit )

!*****************************************************************************80
!
!! GET_UNIT returns a free FORTRAN unit number.
!
!  Discussion:
!
!    A "free" FORTRAN unit number is an integer between 1 and 99 which
!    is not currently associated with an I/O device.  A free FORTRAN unit
!    number is needed in order to open a file with the OPEN command.
!
!    If IUNIT = 0, then no free FORTRAN unit could be found, although
!    all 99 units were checked (except for units 5, 6 and 9, which
!    are commonly reserved for console I/O).
!
!    Otherwise, IUNIT is an integer between 1 and 99, representing a
!    free FORTRAN unit.  Note that GET_UNIT assumes that units 5 and 6
!    are special, and will never return those values.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 September 2005
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Output, integer  IUNIT, the free unit number.
!
  implicit none

  integer  i
  integer  ios
  integer  iunit
  logical lopen

  iunit = 0

  do i = 1, 99

    if ( i /= 5 .and. i /= 6 .and. i /= 9 ) then

      inquire ( unit = i, opened = lopen, iostat = ios )

      if ( ios == 0 ) then
        if ( .not. lopen ) then
          iunit = i
          return
        end if
      end if

    end if

  end do

  return
end
subroutine imtqlx ( n, d, e, z )

!*****************************************************************************80
!
!! IMTQLX diagonalizes a symmetric tridiagonal matrix.
!
!  Discussion:
!
!    This routine is a slightly modified version of the EISPACK routine to
!    perform the implicit QL algorithm on a symmetric tridiagonal matrix.
!
!    The authors thank the authors of EISPACK for permission to use this
!    routine.
!
!    It has been modified to produce the product Q' * Z, where Z is an input
!    vector and Q is the orthogonal matrix diagonalizing the input matrix.
!    The changes consist (essentially) of applying the orthogonal transformations
!    directly to Z as they are generated.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    27 December 2009
!
!  Author:
!
!    Original FORTRAN77 version by Sylvan Elhay, Jaroslav Kautsky.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Sylvan Elhay, Jaroslav Kautsky,
!    Algorithm 655: IQPACK, FORTRAN Subroutines for the Weights of
!    Interpolatory Quadrature,
!    ACM Transactions on Mathematical Software,
!    Volume 13, Number 4, December 1987, pages 399-415.
!
!    Roger Martin, James Wilkinson,
!    The Implicit QL Algorithm,
!    Numerische Mathematik,
!    Volume 12, Number 5, December 1968, pages 377-383.
!
!  Parameters:
!
!    Input, integer  N, the order of the matrix.
!
!    Input/output, double precision D(N), the diagonal entries of the matrix.
!    On output, the information in D has been overwritten.
!
!    Input/output, double precision E(N), the subdiagonal entries of the
!    matrix, in entries E(1) through E(N-1).  On output, the information in
!    E has been overwritten.
!
!    Input/output, double precision Z(N).  On input, a vector.  On output,
!    the value of Q' * Z, where Q is the matrix that diagonalizes the
!    input symmetric tridiagonal matrix.
!
  implicit none

  integer  n

  double precision b
  double precision c
  double precision d(n)
  double precision e(n)
  double precision f
  double precision g
  integer  i
  integer  ii
  integer , parameter :: itn = 30
  integer  j
  integer  k
  integer  l
  integer  m
  integer  mml
  double precision p
  double precision prec
  double precision r
  double precision s
  double precision z(n)

  prec = epsilon ( prec )

  if ( n == 1 ) then
    return
  end if

  e(n) = 0.0D+00

  do l = 1, n

    j = 0

    do

      do m = l, n

        if ( m == n ) then
          exit
        end if

        if ( abs ( e(m) ) <= prec * ( abs ( d(m) ) + abs ( d(m+1) ) ) ) then
          exit
        end if

      end do

      p = d(l)

      if ( m == l ) then
        exit
      end if

      if ( itn <= j ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'IMTQLX - Fatal error!'
        write ( *, '(a)' ) '  Iteration limit exceeded.'
        write ( *, '(a,i8)' ) '  J = ', j
        write ( *, '(a,i8)' ) '  L = ', l
        write ( *, '(a,i8)' ) '  M = ', m
        write ( *, '(a,i8)' ) '  N = ', n
        stop
      end if

      j = j + 1
      g = ( d(l+1) - p ) / ( 2.0D+00 * e(l) )
      r =  sqrt ( g * g + 1.0D+00 )
      g = d(m) - p + e(l) / ( g + sign ( r, g ) )
      s = 1.0D+00
      c = 1.0D+00
      p = 0.0D+00
      mml = m - l

      do ii = 1, mml

        i = m - ii
        f = s * e(i)
        b = c * e(i)

        if ( abs ( g ) <= abs ( f ) ) then
          c = g / f
          r =  sqrt ( c * c + 1.0D+00 )
          e(i+1) = f * r
          s = 1.0D+00 / r
          c = c * s
        else
          s = f / g
          r =  sqrt ( s * s + 1.0D+00 )
          e(i+1) = g * r
          c = 1.0D+00 / r
          s = s * c
        end if

        g = d(i+1) - p
        r = ( d(i) - g ) * s + 2.0D+00 * c * b
        p = s * r
        d(i+1) = g + p
        g = c * r - b
        f = z(i+1)
        z(i+1) = s * z(i) + c * f
        z(i) = c * z(i) - s * f

      end do

      d(l) = d(l) - p
      e(l) = g
      e(m) = 0.0D+00

    end do

  end do
!
!  Sorting.
!
  do ii = 2, n

    i = ii - 1
    k = i
    p = d(i)

    do j = ii, n
      if ( d(j) < p ) then
        k = j
        p = d(j)
      end if
    end do

    if ( k /= i ) then
      d(k) = d(i)
      d(i) = p
      p = z(i)
      z(i) = z(k)
      z(k) = p
    end if

  end do

  return
end
subroutine parchk ( kind, m, alpha, beta )

!*****************************************************************************80
!
!! PARCHK checks parameters ALPHA and BETA for classical weight functions.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    27 December 2009
!
!  Author:
!
!    Original FORTRAN77 version by Sylvan Elhay, Jaroslav Kautsky.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Sylvan Elhay, Jaroslav Kautsky,
!    Algorithm 655: IQPACK, FORTRAN Subroutines for the Weights of
!    Interpolatory Quadrature,
!    ACM Transactions on Mathematical Software,
!    Volume 13, Number 4, December 1987, pages 399-415.
!
!  Parameters:
!
!    Input, integer  KIND, the rule.
!    1, Legendre,             (a,b)       1.0
!    2, Chebyshev,            (a,b)       ((b-x)*(x-a))^(-0.5)
!    3, Gegenbauer,           (a,b)       ((b-x)*(x-a))^alpha
!    4, Jacobi,               (a,b)       (b-x)^alpha*(x-a)^beta
!    5, Generalized Laguerre, (a,inf)     (x-a)^alpha*exp(-b*(x-a))
!    6, Generalized Hermite,  (-inf,inf)  |x-a|^alpha*exp(-b*(x-a)^2)
!    7, Exponential,          (a,b)       |x-(a+b)/2.0|^alpha
!    8, Rational,             (a,inf)     (x-a)^alpha*(x+b)^beta
!
!    Input, integer  M, the order of the highest moment to
!    be calculated.  This value is only needed when KIND = 8.
!
!    Input, double precision ALPHA, BETA, the parameters, if required
!    by the value of KIND.
!
  implicit none

  double precision alpha
  double precision beta
  integer  kind
  integer  m
  double precision tmp

  if ( kind <= 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'PARCHK - Fatal error!'
    write ( *, '(a)' ) '  KIND <= 0.'
    stop
  end if
!
!  Check ALPHA for Gegenbauer, Jacobi, Laguerre, Hermite, Exponential.
!
  if ( 3 <= kind .and. alpha <= -1.0D+00 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'PARCHK - Fatal error!'
    write ( *, '(a)' ) '  3 <= KIND and ALPHA <= -1.'
    stop
  end if
!
!  Check BETA for Jacobi.
!
  if ( kind == 4 .and. beta <= -1.0D+00 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'PARCHK - Fatal error!'
    write ( *, '(a)' ) '  KIND == 4 and BETA <= -1.0.'
    stop
  end if
!
!  Check ALPHA and BETA for rational.
!
  if ( kind == 8 ) then
    tmp = alpha + beta + real ( m + 1, kind = 8 )
    if ( 0.0D+00 <= tmp .or. tmp <= beta ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'PARCHK - Fatal error!'
      write ( *, '(a)' ) '  KIND == 8 but condition on ALPHA and BETA fails.'
      stop
    end if
  end if

  return
end
function r8_gamma ( x )

!*****************************************************************************80
!
!! R8_GAMMA evaluates Gamma(X) for a real argument.
!
!  Discussion:
!
!    This routine calculates the gamma function for a real argument X.
!
!    Computation is based on an algorithm outlined in reference 1.
!    The program uses rational functions that approximate the gamma
!    function to at least 20 significant decimal digits.  Coefficients
!    for the approximation over the interval (1,2) are unpublished.
!    Those for the approximation for 12 <= X are from reference 2.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    11 February 2008
!
!  Author:
!
!    Original FORTRAN77 version by William Cody, Laura Stoltz.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    William Cody,
!    An Overview of Software Development for Special Functions,
!    in Numerical Analysis Dundee, 1975,
!    edited by GA Watson,
!    Lecture Notes in Mathematics 506,
!    Springer, 1976.
!
!    John Hart, Ward Cheney, Charles Lawson, Hans Maehly,
!    Charles Mesztenyi, John Rice, Henry Thatcher,
!    Christoph Witzgall,
!    Computer Approximations,
!    Wiley, 1968,
!    LC: QA297.C64.
!
!  Parameters:
!
!    Input, double precision X, the argument of the function.
!
!    Output, double precision R8_GAMMA, the value of the function.
!
  implicit none

  double precision, dimension ( 7 ) :: c = (/ &
   -1.910444077728D-03, &
    8.4171387781295D-04, &
   -5.952379913043012D-04, &
    7.93650793500350248D-04, &
   -2.777777777777681622553D-03, &
    8.333333333333333331554247D-02, &
    5.7083835261D-03 /)
  double precision, parameter :: eps = 2.22D-16
  double precision fact
  integer  i
  integer  n
  double precision, dimension ( 8 ) :: p = (/ &
    -1.71618513886549492533811D+00, &
     2.47656508055759199108314D+01, &
    -3.79804256470945635097577D+02, &
     6.29331155312818442661052D+02, &
     8.66966202790413211295064D+02, &
    -3.14512729688483675254357D+04, &
    -3.61444134186911729807069D+04, &
     6.64561438202405440627855D+04 /)
  logical parity
  double precision, parameter :: pi = 3.1415926535897932384626434D+00
  double precision, dimension ( 8 ) :: q = (/ &
    -3.08402300119738975254353D+01, &
     3.15350626979604161529144D+02, &
    -1.01515636749021914166146D+03, &
    -3.10777167157231109440444D+03, &
     2.25381184209801510330112D+04, &
     4.75584627752788110767815D+03, &
    -1.34659959864969306392456D+05, &
    -1.15132259675553483497211D+05 /)
  double precision r8_gamma
  double precision res
  double precision, parameter :: sqrtpi = 0.9189385332046727417803297D+00
  double precision sum
  double precision x
  double precision, parameter :: xbig = 171.624D+00
  double precision xden
  double precision, parameter :: xinf = 1.0D+30
  double precision, parameter :: xminin = 2.23D-308
  double precision xnum
  double precision y
  double precision y1
  double precision ysq
  double precision z

  parity = .false.
  fact = 1.0D+00
  n = 0
  y = x
!
!  Argument is negative.
!
  if ( y <= 0.0D+00 ) then

    y = - x
    y1 = aint ( y )
    res = y - y1

    if ( res /= 0.0D+00 ) then

      if ( y1 /= aint ( y1 * 0.5D+00 ) * 2.0D+00 ) then
        parity = .true.
      end if

      fact = - pi / sin ( pi * res )
      y = y + 1.0D+00

    else

      res = xinf
      r8_gamma = res
      return

    end if

  end if
!
!  Argument is positive.
!
  if ( y < eps ) then
!
!  Argument < EPS.
!
    if ( xminin <= y ) then
      res = 1.0D+00 / y
    else
      res = xinf
      r8_gamma = res
      return
    end if

  else if ( y < 12.0D+00 ) then

    y1 = y
!
!  0.0 < argument < 1.0.
!
    if ( y < 1.0D+00 ) then

      z = y
      y = y + 1.0D+00
!
!  1.0 < argument < 12.0.
!  Reduce argument if necessary.
!
    else

      n = int ( y ) - 1
      y = y - real ( n, kind = 8 )
      z = y - 1.0D+00

    end if
!
!  Evaluate approximation for 1.0 < argument < 2.0.
!
    xnum = 0.0D+00
    xden = 1.0D+00
    do i = 1, 8
      xnum = ( xnum + p(i) ) * z
      xden = xden * z + q(i)
    end do

    res = xnum / xden + 1.0D+00
!
!  Adjust result for case  0.0 < argument < 1.0.
!
    if ( y1 < y ) then

      res = res / y1
!
!  Adjust result for case 2.0 < argument < 12.0.
!
    else if ( y < y1 ) then

      do i = 1, n
        res = res * y
        y = y + 1.0D+00
      end do

    end if

  else
!
!  Evaluate for 12.0 <= argument.
!
    if ( y <= xbig ) then

      ysq = y * y
      sum = c(7)
      do i = 1, 6
        sum = sum / ysq + c(i)
      end do
      sum = sum / y - y + sqrtpi
      sum = sum + ( y - 0.5D+00 ) * log ( y )
      res = exp ( sum )

    else

      res = xinf
      r8_gamma = res
      return

    end if

  end if
!
!  Final adjustments and return.
!
  if ( parity ) then
    res = - res
  end if

  if ( fact /= 1.0D+00 ) then
    res = fact / res
  end if

  r8_gamma = res

  return
end
function r8_huge ( )

!*****************************************************************************80
!
!! R8_HUGE returns a very large R8.
!
!  Discussion:
!
!    The value returned by this function is NOT required to be the
!    maximum representable R8.  This value varies from machine to machine,
!    from compiler to compiler, and may cause problems when being printed.
!    We simply want a "very large" but non-infinite number.
!
!    FORTRAN90 provides a built-in routine HUGE ( X ) that
!    can return the maximum representable number of the same datatype
!    as X, if that is what is really desired.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    12 October 2007
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Output, double precision R8_HUGE, a "huge" value.
!
  implicit none

  double precision r8_huge

  r8_huge = 1.0D+30

  return
end

subroutine scqf ( nt, t, mlt, wts, nwts, ndx, swts, st, kind, alpha, beta, a, &
  b )
!*****************************************************************************80
!
!! SCQF scales a quadrature formula to a nonstandard interval.
!
!  Discussion:
!
!    The arrays WTS and SWTS may coincide.
!
!    The arrays T and ST may coincide.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    27 December 2009
!
!  Author:
!
!    Original FORTRAN77 version by Sylvan Elhay, Jaroslav Kautsky.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Sylvan Elhay, Jaroslav Kautsky,
!    Algorithm 655: IQPACK, FORTRAN Subroutines for the Weights of
!    Interpolatory Quadrature,
!    ACM Transactions on Mathematical Software,
!    Volume 13, Number 4, December 1987, pages 399-415.
!
!  Parameters:
!
!    Input, integer  NT, the number of knots.
!
!    Input, double precision T(NT), the original knots.
!
!    Input, integer  MLT(NT), the multiplicity of the knots.
!
!    Input, double precision WTS(NWTS), the weights.
!
!    Input, integer  NWTS, the number of weights.
!
!    Input, integer  NDX(NT), used to index the array WTS.
!    For more details see the comments in CAWIQ.
!
!    Output, double precision SWTS(NWTS), the scaled weights.
!
!    Output, double precision ST(NT), the scaled knots.
!
!    Input, integer  KIND, the rule.
!    1, Legendre,             (a,b)       1.0
!    2, Chebyshev Type 1,     (a,b)       ((b-x)*(x-a))^(-0.5)
!    3, Gegenbauer,           (a,b)       ((b-x)*(x-a))^alpha
!    4, Jacobi,               (a,b)       (b-x)^alpha*(x-a)^beta
!    5, Generalized Laguerre, (a,+oo)     (x-a)^alpha*exp(-b*(x-a))
!    6, Generalized Hermite,  (-oo,+oo)   |x-a|^alpha*exp(-b*(x-a)^2)
!    7, Exponential,          (a,b)       |x-(a+b)/2.0|^alpha
!    8, Rational,             (a,+oo)     (x-a)^alpha*(x+b)^beta
!    9, Chebyshev Type 2,     (a,b)       ((b-x)*(x-a))^(+0.5)
!
!    Input, double precision ALPHA, the value of Alpha, if needed.
!
!    Input, double precision BETA, the value of Beta, if needed.
!
!    Input, double precision A, B, the interval endpoints.
!
  implicit none

  integer  nt
  integer  nwts

  double precision a
  double precision al
  double precision alpha
  double precision b
  double precision be
  double precision beta
  integer  i
  integer  k
  integer  kind
  integer  l
  integer  mlt(nt)
  integer  ndx(nt)
  double precision p
  double precision shft
  double precision slp
  double precision st(nt)
  double precision swts(nwts)
  double precision t(nt)
  double precision temp
  double precision tmp
  double precision wts(nwts)

  temp = epsilon ( temp )

  call parchk ( kind, 1, alpha, beta )

  if ( kind == 1 ) then

    al = 0.0D+00
    be = 0.0D+00

    if ( abs ( b - a ) <= temp ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'SCQF - Fatal error!'
      write ( *, '(a)' ) '  |B - A| too small.'
      stop
    end if

    shft = ( a + b ) / 2.0D+00
    slp = ( b - a ) / 2.0D+00

  else if ( kind == 2 ) then

    al = -0.5D+00
    be = -0.5D+00

    if ( abs ( b - a ) <= temp ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'SCQF - Fatal error!'
      write ( *, '(a)' ) '  |B - A| too small.'
      stop
    end if

    shft = ( a + b ) / 2.0D+00
    slp = ( b - a ) / 2.0D+00

  else if ( kind == 3 ) then

    al = alpha
    be = alpha

    if ( abs ( b - a ) <= temp ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'SCQF - Fatal error!'
      write ( *, '(a)' ) '  |B - A| too small.'
      stop
    end if

    shft = ( a + b ) / 2.0D+00
    slp = ( b - a ) / 2.0D+00

  else if ( kind == 4 ) then

    al = alpha
    be = beta

    if ( abs ( b - a ) <= temp ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'SCQF - Fatal error!'
      write ( *, '(a)' ) '  |B - A| too small.'
      stop
    end if

    shft = ( a + b ) / 2.0D+00
    slp = ( b - a ) / 2.0D+00

  else if ( kind == 5 ) then

    if ( b <= 0.0D+00 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'SCQF - Fatal error!'
      write ( *, '(a)' ) '  B <= 0'
      stop
    end if

    shft = a
    slp = 1.0D+00 / b
    al = alpha
    be = 0.0D+00

  else if ( kind == 6 ) then

    if ( b <= 0.0D+00 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'SCQF - Fatal error!'
      write ( *, '(a)' ) '  B <= 0.'
      stop
    end if

    shft = a
    slp = 1.0D+00 / sqrt ( b )
    al = alpha
    be = 0.0D+00

  else if ( kind == 7 ) then

    al = alpha
    be = 0.0D+00

    if ( abs ( b - a ) <= temp ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'SCQF - Fatal error!'
      write ( *, '(a)' ) '  |B - A| too small.'
      stop
    end if

    shft = ( a + b ) / 2.0D+00
    slp = ( b - a ) / 2.0D+00

  else if ( kind == 8 ) then

    if ( a + b <= 0.0D+00 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'SCQF - Fatal error!'
      write ( *, '(a)' ) '  A + B <= 0.'
      stop
    end if

    shft = a
    slp = a + b
    al = alpha
    be = beta

  else if ( kind == 9 ) then

    al = 0.5D+00
    be = 0.5D+00

    if ( abs ( b - a ) <= temp ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'SCQF - Fatal error!'
      write ( *, '(a)' ) '  |B - A| too small.'
      stop
    end if

    shft = ( a + b ) / 2.0D+00
    slp = ( b - a ) / 2.0D+00

  end if

  p = slp**( al + be + 1.0D+00 )

  do k = 1, nt

    st(k) = shft + slp * t(k)
    l = abs ( ndx(k) )

    if ( l /= 0 ) then
      tmp = p
      do i = l, l + mlt(k) - 1
        swts(i) = wts(i) * tmp
        tmp = tmp * slp
      end do
    end if

  end do

  return
end
subroutine sgqf ( nt, aj, bj, zemu, t, wts )

!*****************************************************************************80
!
!! SGQF computes knots and weights of a Gauss Quadrature formula.
!
!  Discussion:
!
!    This routine computes all the knots and weights of a Gauss quadrature
!    formula with simple knots from the Jacobi matrix and the zero-th
!    moment of the weight function, using the Golub-Welsch technique.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    04 January 2010
!
!  Author:
!
!    Original FORTRAN77 version by Sylvan Elhay, Jaroslav Kautsky.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Sylvan Elhay, Jaroslav Kautsky,
!    Algorithm 655: IQPACK, FORTRAN Subroutines for the Weights of
!    Interpolatory Quadrature,
!    ACM Transactions on Mathematical Software,
!    Volume 13, Number 4, December 1987, pages 399-415.
!
!  Parameters:
!
!    Input, integer  NT, the number of knots.
!
!    Input, double precision AJ(NT), the diagonal of the Jacobi matrix.
!
!    Input/output, double precision BJ(NT), the subdiagonal of the Jacobi
!    matrix, in entries 1 through NT-1.  On output, BJ has been overwritten.
!
!    Input, double precision ZEMU, the zero-th moment of the weight function.
!
!    Output, double precision T(NT), the knots.
!
!    Output, double precision WTS(NT), the weights.
!
  implicit none

  integer  nt

  double precision aj(nt)
  double precision bj(nt)
  integer  i
  double precision t(nt)
  double precision wts(nt)
  double precision zemu
!
!  Exit if the zero-th moment is not positive.
!
  if ( zemu <= 0.0D+00 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'SGQF - Fatal error!'
    write ( *, '(a)' ) '  ZEMU <= 0.'
    stop
  end if
!
!  Set up vectors for IMTQLX.
!
  t(1:nt) = aj(1:nt)

  wts(1) = sqrt ( zemu )
  wts(2:nt) = 0.0D+00
!
!  Diagonalize the Jacobi matrix.
!
  call imtqlx ( nt, t, bj, wts )

  wts(1:nt) = wts(1:nt)**2

  return
end

max_stars_repo_name: dimpase/tt-fort

max_issues_repo_name: dimpase/tt-fort

max_forks_repo_name: dimpase/tt-fort


text:
      double complex function Fsc4(j1,j2,j3,j4,j5,j6,za,zb)
      implicit none
      include 'constants.f'
      include 'zprods_decl.f'
      include 'sprods_com.f'
      integer j1,j2,j3,j4,j5,j6
      double complex L0,L1,Lsm1_2mh,I3m,Lnrat
      double precision t
      double complex fac

      Fsc4=
     .-(Lnrat(-s(j2,j3),-s(j5,j6))*zb(j1,j2)*
     .((za(j1,j5)*za(j3,j5)*zb(j1,j3)+za(j1,j5)*za(j4,j5)*zb(j1,j4))/
     .za(j5,j6)-(-(za(j1,j4)*zb(j1,j6)*zb(j4,j6))-
     .za(j2,j4)*zb(j2,j6)*zb(j4,j6))/zb(j5,j6)))/
     .(2d0*zb(j1,j4)*(za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4))*
     .(-(za(j1,j2)*zb(j1,j3))-za(j2,j4)*zb(j3,j4)))

      fac=
     .-(za(j2,j4)*((za(j4,j5)*
     .(-((za(j3,j5)*
     .((s(j1,j4)-s(j2,j3)-s(j5,j6))*za(j1,j4)*
     .zb(j1,j3)-
     .(-s(j1,j4)+s(j2,j3)-s(j5,j6))*za(j2,j4)*
     .zb(j2,j3)))/za(j5,j6))+
     .((-s(j1,j4)-s(j2,j3)+s(j5,j6))*za(j2,j4)+
     .2d0*za(j1,j4)*za(j2,j3)*zb(j1,j3))*zb(j2,j6)))/
     .za(j1,j4)-(zb(j1,j6)*
     .(-(za(j3,j5)*
     .(-((-s(j1,j4)-s(j2,j3)+s(j5,j6))*zb(j1,j3))-
     .2d0*za(j2,j4)*zb(j1,j4)*zb(j2,j3)))-
     .((-((-s(j1,j4)+s(j2,j3)-s(j5,j6))*za(j2,j3)*
     .zb(j1,j3))+
     .(s(j1,j4)-s(j2,j3)-s(j5,j6))*za(j2,j4)*
     .zb(j1,j4))*zb(j2,j6))/zb(j5,j6)))/zb(j1,j4)))/
     .(2d0*(s(j1,j4)**2-2d0*s(j1,j4)*s(j2,j3)+s(j2,j3)**2-
     .2d0*s(j1,j4)*s(j5,j6)-2d0*s(j2,j3)*s(j5,j6)+s(j5,j6)**2)*za(j1,j2)
     .*
     .(-(za(j1,j2)*zb(j1,j3))-za(j2,j4)*zb(j3,j4)))+
     .(za(j2,j4)*zb(j1,j2)*(-(za(j1,j2)*zb(j1,j6))+
     .za(j2,j4)*zb(j4,j6))*
     .((L0(-t(j1,j2,j4),-s(j1,j4))*
     .((-2d0*za(j2,j4)*zb(j3,j6))/
     .(-(za(j1,j2)*zb(j1,j3))-za(j2,j4)*zb(j3,j4))+
     .(-(za(j1,j4)*zb(j1,j6))-za(j2,j4)*zb(j2,j6))/
     .t(j1,j2,j4)))/s(j1,j4)-
     .(L1(-s(j1,j4),-t(j1,j2,j4))*za(j2,j4)*zb(j2,j6))/t(j1,j2,j4)**2))/
     .(2d0*za(j1,j2)*(-(za(j1,j2)*zb(j1,j3))-za(j2,j4)*zb(j3,j4))*
     .zb(j5,j6))
      fac=fac+(za(j2,j4)*za(j3,j4)*zb(j3,j6)**2*
     .((-2d0*L0(-s(j5,j6),-t(j1,j2,j4))*za(j2,j4))/
     .(-(za(j1,j2)*zb(j1,j3))-za(j2,j4)*zb(j3,j4))+
     .(L1(-s(j5,j6),-t(j1,j2,j4))*za(j3,j4))/t(j1,j2,j4)))/
     .(2d0*za(j1,j2)*za(j1,j4)*
     .(-(za(j1,j2)*zb(j1,j3))-za(j2,j4)*zb(j3,j4))*zb(j5,j6))-
     .(Lsm1_2mh(s(j2,j3),t(j1,j2,j4),s(j1,j4),s(j5,j6))*za(j2,j4)**3*
     .zb(j3,j6)**2*t(j1,j2,j4))/
     .(za(j1,j2)*za(j1,j4)*(-(za(j1,j2)*zb(j1,j3))-
     .za(j2,j4)*zb(j3,j4))**3*zb(j5,j6))-
     .(Lnrat(-s(j2,j3),-s(j5,j6))*za(j2,j4)*
     .(-((za(j2,j5)*za(j4,j5)*zb(j1,j2))/za(j5,j6))+
     .(2d0*(-s(j1,j4)-s(j2,j3)+s(j5,j6))*
     .(za(j2,j5)*za(j3,j4)+za(j2,j4)*za(j3,j5))*zb(j1,j6)*
     .zb(j2,j3))/
     .(s(j1,j4)**2-2d0*s(j1,j4)*s(j2,j3)+s(j2,j3)**2-
     .2d0*s(j1,j4)*s(j5,j6)-2d0*s(j2,j3)*s(j5,j6)+s(j5,j6)**2)+
     .((-s(j1,j4)+s(j2,j3)-s(j5,j6))*zb(j2,j3)*
     .(za(j2,j5)*za(j3,j4)*
     .(za(j2,j5)*zb(j1,j2)+za(j3,j5)*zb(j1,j3))-
     .za(j2,j3)*za(j4,j5)*
     .(za(j2,j5)*zb(j1,j2)+za(j4,j5)*zb(j1,j4))+
     .za(j2,j4)*zb(j1,j3)*
     .(za(j3,j5)**2+
     .(za(j2,j5)**2*
     .(-(za(j1,j3)*zb(j1,j2))-za(j3,j4)*zb(j2,j4)))/
     .(-(za(j1,j2)*zb(j1,j3))-za(j2,j4)*zb(j3,j4)))))/
     .((s(j1,j4)**2-2d0*s(j1,j4)*s(j2,j3)+s(j2,j3)**2-
     .2d0*s(j1,j4)*s(j5,j6)-2d0*s(j2,j3)*s(j5,j6)+s(j5,j6)**2)*
     .za(j5,j6))+(za(j2,j4)*zb(j1,j3)*
     .(-((za(j2,j5)*za(j3,j5)*zb(j2,j3))/za(j5,j6))-
     .(za(j2,j3)*zb(j2,j6)*zb(j3,j6))/zb(j5,j6)))/
     .(-(za(j1,j2)*zb(j1,j3))-za(j2,j4)*zb(j3,j4))+
     .((-s(j1,j4)+s(j2,j3)-s(j5,j6))*za(j2,j3)*
     .(-((za(j2,j4)*zb(j1,j2)+za(j3,j4)*zb(j1,j3))*
     .zb(j2,j6)*zb(j3,j6))-
     .(za(j2,j4)*zb(j1,j3)*
     .(-(za(j1,j3)*zb(j1,j2))-za(j3,j4)*zb(j2,j4))*
     .zb(j3,j6)**2)/
     .(-(za(j1,j2)*zb(j1,j3))-za(j2,j4)*zb(j3,j4))-
     .za(j2,j4)*zb(j2,j6)*
     .(-(zb(j1,j6)*zb(j2,j3))+zb(j1,j2)*zb(j3,j6))))/
     .((s(j1,j4)**2-2d0*s(j1,j4)*s(j2,j3)+s(j2,j3)**2-
     .2d0*s(j1,j4)*s(j5,j6)-2d0*s(j2,j3)*s(j5,j6)+s(j5,j6)**2)*
     .zb(j5,j6))-(s(j2,j3)*
     .(-((za(j4,j5)**2*zb(j1,j4))/za(j5,j6))-
     .(za(j1,j4)*zb(j1,j6)**2)/zb(j5,j6))*t(j1,j2,j4))/
     .(s(j1,j4)**2-2d0*s(j1,j4)*s(j2,j3)+s(j2,j3)**2-
     .2d0*s(j1,j4)*s(j5,j6)-2d0*s(j2,j3)*s(j5,j6)+s(j5,j6)**2)+
     .(6d0*s(j1,j4)*s(j2,j3)*
     .(za(j2,j4)*zb(j1,j2)+za(j3,j4)*zb(j1,j3))*
     .(-(za(j2,j5)*zb(j2,j6))-za(j3,j5)*zb(j3,j6))*
     .(-t(j1,j2,j4)+t(j1,j3,j4)))/
     .(s(j1,j4)**2-2d0*s(j1,j4)*s(j2,j3)+s(j2,j3)**2-
     .2d0*s(j1,j4)*s(j5,j6)-2d0*s(j2,j3)*s(j5,j6)+s(j5,j6)**2)**2))/
     .(2d0*s(j1,j4)*za(j1,j2)*(-(za(j1,j2)*zb(j1,j3))-
     .za(j2,j4)*zb(j3,j4)))
      fac=fac-
     .(I3m(s(j2,j3),s(j1,j4),s(j5,j6))*za(j2,j4)*
     .((za(j2,j4)*zb(j1,j3)*
     .(-(za(j1,j3)*zb(j1,j2))-za(j3,j4)*zb(j2,j4))*
     .(za(j1,j2)*(za(j2,j5)*zb(j1,j2)+
     .za(j3,j5)*zb(j1,j3))-
     .za(j2,j4)*(-(za(j2,j5)*zb(j2,j4))-
     .za(j3,j5)*zb(j3,j4))+
     .za(j2,j3)*(-(za(j1,j5)*zb(j1,j3))+
     .za(j4,j5)*zb(j3,j4)))*zb(j3,j6))/
     .(-(za(j1,j2)*zb(j1,j3))-za(j2,j4)*zb(j3,j4))-
     .zb(j1,j2)*(za(j2,j4)*
     .(za(j1,j3)*(za(j2,j5)*zb(j1,j2)+
     .za(j3,j5)*zb(j1,j3))-
     .za(j2,j3)*
     .(-(za(j1,j5)*zb(j1,j2))+za(j4,j5)*zb(j2,j4))-
     .za(j3,j4)*
     .(-(za(j2,j5)*zb(j2,j4))-za(j3,j5)*zb(j3,j4)))+
     .za(j2,j3)*(-(za(j2,j4)*
     .(-(za(j1,j5)*zb(j1,j2))+za(j4,j5)*zb(j2,j4)))-
     .za(j3,j4)*
     .(-(za(j1,j5)*zb(j1,j3))+za(j4,j5)*zb(j3,j4))))*
     .zb(j3,j6)+(s(j2,j3)*
     .(za(j2,j4)*zb(j1,j2)+za(j3,j4)*zb(j1,j3))*
     .(-(za(j2,j5)*zb(j2,j6))-za(j3,j5)*zb(j3,j6)))/2+
     .za(j3,j4)*zb(j2,j3)*
     .(za(j2,j3)*za(j4,j5)*zb(j1,j4)*zb(j3,j6)+
     .(-(za(j2,j3)*zb(j1,j3))-za(j2,j4)*zb(j1,j4))*
     .(-(za(j2,j5)*zb(j2,j6))-za(j3,j5)*zb(j3,j6)))+
     .(3d0*s(j2,j3)*(-s(j1,j4)+s(j2,j3)-s(j5,j6))*
     .(za(j2,j4)*zb(j1,j2)+za(j3,j4)*zb(j1,j3))*
     .(-(za(j2,j5)*zb(j2,j6))-za(j3,j5)*zb(j3,j6))*
     .(-t(j1,j2,j4)+t(j1,j3,j4)))/
     .(2d0*(s(j1,j4)**2-2d0*s(j1,j4)*s(j2,j3)+s(j2,j3)**2-
     .2d0*s(j1,j4)*s(j5,j6)-2d0*s(j2,j3)*s(j5,j6)+s(j5,j6)**2))))/
     .((s(j1,j4)**2-2d0*s(j1,j4)*s(j2,j3)+s(j2,j3)**2-
     .2d0*s(j1,j4)*s(j5,j6)-2d0*s(j2,j3)*s(j5,j6)+s(j5,j6)**2)*za(j1,j2)
     .*
     .(-(za(j1,j2)*zb(j1,j3))-za(j2,j4)*zb(j3,j4)))
      fac=fac-
     .(Lnrat(-s(j1,j4),-s(j5,j6))*za(j2,j4)*
     .(4d0*(za(j2,j5)*za(j3,j4)*zb(j1,j6)*zb(j2,j3)+
     .za(j2,j3)*za(j4,j5)*zb(j1,j3)*zb(j2,j6))-
     .(8d0*s(j2,j3)*za(j2,j4)*za(j5,j6)*zb(j1,j6)*zb(j3,j6))/
     .(-(za(j1,j2)*zb(j1,j3))-za(j2,j4)*zb(j3,j4))-
     .2d0*(-(za(j2,j4)*zb(j1,j2))+za(j3,j4)*zb(j1,j3))*
     .(-(za(j2,j5)*zb(j2,j6))-za(j3,j5)*zb(j3,j6))+
     .(za(j2,j4)*zb(j1,j2)+za(j3,j4)*zb(j1,j3)-
     .(4d0*s(j5,j6)*za(j2,j4)*zb(j1,j3))/
     .(-(za(j1,j2)*zb(j1,j3))-za(j2,j4)*zb(j3,j4)))*
     .((za(j2,j5)*za(j3,j5)*zb(j2,j3))/za(j5,j6)-
     .(za(j2,j3)*zb(j2,j6)*zb(j3,j6))/zb(j5,j6))-
     .(s(j1,j4)-s(j2,j3)-s(j5,j6))*
     .(-((za(j2,j5)*za(j4,j5)*zb(j1,j2))/za(j5,j6))-
     .(za(j3,j4)*zb(j1,j6)*zb(j3,j6))/zb(j5,j6)-
     .(2d0*za(j2,j4)*zb(j3,j6)*
     .(za(j2,j3)*zb(j1,j2)*zb(j3,j6)-
     .za(j3,j4)*zb(j1,j4)*zb(j3,j6)-
     .za(j2,j5)*zb(j1,j2)*zb(j5,j6)))/
     .((-(za(j1,j2)*zb(j1,j3))-za(j2,j4)*zb(j3,j4))*
     .zb(j5,j6)))+
     .(3d0*(-s(j1,j4)-s(j2,j3)+s(j5,j6))*
     .(za(j2,j4)*zb(j1,j2)+za(j3,j4)*zb(j1,j3))*
     .(-(za(j2,j5)*zb(j2,j6))-za(j3,j5)*zb(j3,j6))*
     .(-t(j1,j2,j4)+t(j1,j3,j4)))/
     .(s(j1,j4)**2-2d0*s(j1,j4)*s(j2,j3)+s(j2,j3)**2-
     .2d0*s(j1,j4)*s(j5,j6)-2d0*s(j2,j3)*s(j5,j6)+s(j5,j6)**2)))/
     .(2d0*(s(j1,j4)**2-2d0*s(j1,j4)*s(j2,j3)+s(j2,j3)**2-
     .2d0*s(j1,j4)*s(j5,j6)-2d0*s(j2,j3)*s(j5,j6)+s(j5,j6)**2)*za(j1,j2)
     .*
     .(-(za(j1,j2)*zb(j1,j3))-za(j2,j4)*zb(j3,j4)))

      Fsc4=Fsc4+za(j1,j4)/za(j2,j4)*fac

      Fsc4=Fsc4-
     .(za(j1,j5)*zb(j1,j2)*((L0(-t(j2,j3,j4),-s(j5,j6))*
     .(za(j3,j5)*zb(j2,j3)+za(j4,j5)*zb(j2,j4)))/(s(j5,j6)*za(j5,j6))
     .+(L1(-s(j5,j6),-t(j2,j3,j4))*(-(za(j1,j3)*zb(j1,j6)*zb(j2,j3))-
     .za(j1,j4)*zb(j1,j6)*zb(j2,j4)))/t(j2,j3,j4)**2))/
     .(2d0*zb(j3,j4)*(za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4)))+
     .(za(j3,j4)*zb(j2,j3)*(-(za(j2,j5)*zb(j2,j4))-za(j3,j5)*zb(j3,j4))*
     .((L1(-t(j2,j3,j4),-s(j2,j3))*za(j4,j5)*zb(j2,j4))/s(j2,j3)**2+
     .(L0(-t(j2,j3,j4),-s(j2,j3))*
     .(za(j3,j5)*zb(j2,j3)+za(j4,j5)*zb(j2,j4)))/(s(j2,j3)*t(j2,j3,j4))
     .))/(2d0*za(j5,j6)*zb(j3,j4)*(za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j
     .4)))+
     .(-((za(j1,j3)*za(j3,j5)*za(j4,j5))/
     .(za(j1,j2)*za(j2,j3)*za(j5,j6)*
     .(za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4))))-
     .(za(j1,j5)*za(j3,j5)*zb(j1,j2))/
     .(za(j2,j3)*za(j5,j6)*zb(j3,j4)*
     .(za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4)))-
     .(za(j3,j5)**2*zb(j1,j3)**2)/
     .(za(j2,j3)*za(j5,j6)*zb(j1,j4)*zb(j3,j4)*
     .(-(za(j1,j2)*zb(j1,j3))-za(j2,j4)*zb(j3,j4)))-
     .(s(j3,j4)*za(j1,j5)*za(j4,j5))/
     .(za(j1,j2)*za(j5,j6)*(za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4))*
     .(-(za(j1,j2)*zb(j1,j3))-za(j2,j4)*zb(j3,j4)))+
     .(za(j1,j5)*za(j3,j4)*za(j3,j5)*zb(j1,j3))/
     .(za(j2,j3)*za(j5,j6)*(za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4))*
     .(-(za(j1,j2)*zb(j1,j3))-za(j2,j4)*zb(j3,j4)))-
     .(za(j1,j3)*zb(j1,j6)**2)/
     .(za(j1,j2)*za(j2,j3)*zb(j1,j4)*zb(j3,j4)*zb(j5,j6))-
     .(za(j1,j3)*zb(j1,j2)*zb(j1,j6)*zb(j4,j6))/
     .(za(j2,j3)*zb(j1,j4)*zb(j3,j4)*
     .(za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4))*zb(j5,j6))+
     .(za(j1,j4)*za(j3,j4)*zb(j3,j6)*zb(j4,j6))/
     .(za(j1,j2)*(za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4))*
     .(-(za(j1,j2)*zb(j1,j3))-za(j2,j4)*zb(j3,j4))*zb(j5,j6))-
     .(s(j1,j3)*za(j3,j4)*zb(j3,j6)*zb(j4,j6))/
     .(za(j2,j3)*zb(j3,j4)*(za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4))*
     .(-(za(j1,j2)*zb(j1,j3))-za(j2,j4)*zb(j3,j4))*zb(j5,j6))+
     .(za(j3,j4)*(za(j1,j2)*zb(j2,j6)+za(j1,j3)*zb(j3,j6))*zb(j4,j6))/
     .(za(j1,j2)*za(j2,j3)*zb(j3,j4)*
     .(za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4))*zb(j5,j6))-
     .(za(j2,j4)*zb(j2,j6)*(-(za(j1,j4)*zb(j1,j6))-za(j2,j4)*zb(j2,j6)))
     ./
     .(za(j1,j2)*(-(za(j1,j2)*zb(j1,j3))-za(j2,j4)*zb(j3,j4))*zb(j5,j6)*
     .t(j1,j2,j4))-(za(j1,j5)*zb(j1,j2)*
     .(za(j3,j5)*zb(j2,j3)+za(j4,j5)*zb(j2,j4)))/
     .(za(j5,j6)*zb(j3,j4)*(za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4))*
     .t(j2,j3,j4)))/2d0

      fac=
     .(za(j4,j5)*zb(j1,j6)*(-((-s(j1,j4)-s(j2,j3)+s(j5,j6))*za(j1,j3))-
     .2d0*za(j1,j4)*za(j2,j3)*zb(j2,j4)))/
     .((s(j1,j4)**2-2d0*s(j1,j4)*s(j2,j3)+s(j2,j3)**2-2d0*s(j1,j4)*s(j5,
     .j6)-
     .2d0*s(j2,j3)*s(j5,j6)+s(j5,j6)**2)*za(j1,j2)*
     .(za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4)))+
     .(((s(j1,j4)-s(j2,j3)-s(j5,j6))*za(j1,j3)*zb(j1,j4)-
     .(-s(j1,j4)+s(j2,j3)-s(j5,j6))*za(j2,j3)*zb(j2,j4))*
     .(-((za(j4,j5)**2*zb(j1,j4))/za(j5,j6))-
     .(za(j1,j4)*zb(j1,j6)**2)/zb(j5,j6)))/
     .(2d0*(s(j1,j4)**2-2d0*s(j1,j4)*s(j2,j3)+s(j2,j3)**2-
     .2d0*s(j1,j4)*s(j5,j6)-2d0*s(j2,j3)*s(j5,j6)+s(j5,j6)**2)*za(j1,j2)
     .*
     .zb(j1,j4)*(za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4)))+
     .(Lsm1_2mh(s(j1,j4),t(j1,j2,j3),s(j2,j3),s(j5,j6))*
     .(-(za(j1,j3)*zb(j1,j4))-za(j2,j3)*zb(j2,j4))*
     .(za(j1,j2)*zb(j2,j6)+za(j1,j3)*zb(j3,j6))**2)/
     .(za(j1,j2)*(za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4))**3*zb(j5,j6))
     .-(L0(-t(j1,j2,j3),-s(j2,j3))*za(j2,j3)*zb(j1,j2)*
     .(za(j1,j2)*zb(j2,j6)+za(j1,j3)*zb(j3,j6))**2)/
     .(s(j2,j3)*za(j1,j2)*(za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4))**2*
     .zb(j5,j6))
      fac=fac+(Lnrat(-s(j2,j3),-s(j5,j6))*za(j2,j3)*
     .((-6d0*(za(j2,j4)*zb(j1,j2)+za(j3,j4)*zb(j1,j3))*zb(j2,j3)*
     .(-((-s(j1,j4)-s(j2,j3)+s(j5,j6))*za(j1,j3))-
     .2d0*za(j1,j4)*za(j2,j3)*zb(j2,j4))*
     .(-(za(j2,j5)*zb(j2,j6))-za(j3,j5)*zb(j3,j6)))/
     .(s(j1,j4)**2-2d0*s(j1,j4)*s(j2,j3)+s(j2,j3)**2-
     .2d0*s(j1,j4)*s(j5,j6)-2d0*s(j2,j3)*s(j5,j6)+s(j5,j6)**2)**2-
     .((za(j1,j2)*zb(j2,j6)+za(j1,j3)*zb(j3,j6))*
     .(zb(j1,j4)*zb(j2,j6)+zb(j1,j2)*zb(j4,j6)))/
     .(zb(j1,j4)*(za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4))*
     .zb(j5,j6))+(-((za(j4,j5)*
     .(za(j4,j5)*zb(j1,j4)*
     .(-(za(j1,j3)*zb(j2,j3))-za(j1,j4)*zb(j2,j4))
     .+2d0*(-((s(j1,j4)-s(j2,j3)-s(j5,j6))*za(j1,j5)*zb(j1,j2))+
     .(-s(j1,j4)-s(j2,j3)+s(j5,j6))*za(j5,j6)*
     .zb(j2,j6))))/za(j5,j6))+
     .((-s(j1,j4)+s(j2,j3)-s(j5,j6))*za(j1,j3)*zb(j2,j3)*
     .(-(za(j1,j5)*zb(j1,j6))+za(j4,j5)*zb(j4,j6)))/
     .(za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4))-
     .(za(j3,j4)*zb(j1,j6)*zb(j2,j3)*
     .(za(j1,j2)*zb(j2,j6)+za(j1,j3)*zb(j3,j6)))/zb(j5,j6)
     .-(zb(j2,j3)*zb(j4,j6)*(-((2d0*(-s(j1,j4)+s(j2,j3)-s(j5,j6))*
     .za(j3,j4)-za(j1,j4)*za(j2,j3)*zb(j1,j2))*
     .zb(j1,j6))-
     .((-s(j1,j4)+s(j2,j3)-s(j5,j6))*za(j1,j3)*
     .(za(j2,j4)*zb(j1,j2)+za(j3,j4)*zb(j1,j3))*
     .zb(j4,j6))/
     .(za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4))))/
     .(zb(j1,j4)*zb(j5,j6))+
     .((-s(j1,j4)+s(j2,j3)-s(j5,j6))*zb(j1,j6)*zb(j2,j4)*
     .(-(za(j2,j4)*zb(j2,j6))-za(j3,j4)*zb(j3,j6)-
     .za(j4,j5)*zb(j5,j6)))/(zb(j1,j4)*zb(j5,j6))+
     .za(j4,j5)*(za(j1,j3)*zb(j1,j6)*zb(j2,j3)+
     .za(j4,j5)*zb(j2,j4)*zb(j5,j6))+
     .4d0*za(j1,j5)*zb(j2,j3)*
     .(za(j3,j4)*zb(j1,j6)+
     .(za(j1,j3)*za(j4,j5)*zb(j1,j4)*zb(j5,j6))/
     .(za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4))))/
     .(s(j1,j4)**2-2d0*s(j1,j4)*s(j2,j3)+s(j2,j3)**2-
     .2d0*s(j1,j4)*s(j5,j6)-2d0*s(j2,j3)*s(j5,j6)+s(j5,j6)**2)))/
     .(2d0*za(j1,j2)*(za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4)))
      fac=fac-
     .(L1(-s(j5,j6),-t(j1,j2,j3))*za(j3,j4)*za(j4,j5)*zb(j4,j6))/
     .(za(j1,j2)*(za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4))*t(j1,j2,j3))
     .-(L0(-t(j1,j2,j3),-s(j5,j6))*za(j3,j4)*
     .(za(j1,j2)*zb(j2,j6)+za(j1,j3)*zb(j3,j6))*zb(j4,j6)*t(j1,j2,j3)
     .)/(s(j5,j6)*za(j1,j2)*(za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4))**2
     .*
     .zb(j5,j6))+(Lnrat(-s(j1,j4),-s(j5,j6))*
     .((-6d0*za(j1,j4)*za(j2,j3)*
     .(za(j2,j4)*zb(j1,j2)+za(j3,j4)*zb(j1,j3))*
     .(2d0*za(j1,j3)*zb(j1,j4)*zb(j2,j3)+
     .(-s(j1,j4)-s(j2,j3)+s(j5,j6))*zb(j2,j4))*
     .(-(za(j2,j5)*zb(j2,j6))-za(j3,j5)*zb(j3,j6)))/
     .(s(j1,j4)**2-2d0*s(j1,j4)*s(j2,j3)+s(j2,j3)**2-
     .2d0*s(j1,j4)*s(j5,j6)-2d0*s(j2,j3)*s(j5,j6)+s(j5,j6)**2)+
     .(za(j4,j5)*(-3d0*(s(j1,j4)-s(j2,j3)-s(j5,j6))*za(j1,j3)*
     .za(j4,j5)*zb(j1,j4)+
     .za(j1,j3)*za(j1,j4)*
     .(za(j2,j5)*zb(j1,j2)+za(j3,j5)*zb(j1,j3))*zb(j1,j4)
     .+za(j1,j4)*za(j2,j3)*(za(j2,j5)*zb(j1,j2)+za(j3,j5)*zb(j1,j3))*
     .zb(j2,j4)+
     .2d0*za(j2,j3)*zb(j1,j2)*
     .((-s(j1,j4)+s(j2,j3)-s(j5,j6))*za(j1,j5)+
     .2d0*za(j1,j4)*za(j5,j6)*zb(j4,j6))))/za(j5,j6)+
     .(za(j1,j4)*zb(j1,j6)*
     .((-(za(j1,j3)*zb(j1,j4))-za(j2,j3)*zb(j2,j4))*
     .(-(za(j2,j4)*zb(j2,j6))-za(j3,j4)*zb(j3,j6))+
     .2d0*((s(j1,j4)-s(j2,j3)-s(j5,j6))*za(j3,j4)*zb(j4,j6)-
     .(-s(j1,j4)-s(j2,j3)+s(j5,j6))*za(j3,j5)*zb(j5,j6)))
     .)/zb(j5,j6)-(za(j1,j3)*((za(j1,j5)*za(j4,j5)*zb(j1,j4))/za(j5,j6)+
     .(za(j1,j4)*zb(j1,j6)*zb(j4,j6))/zb(j5,j6))*
     .(-s(j1,j4)**2+2d0*s(j1,j4)*s(j2,j3)-s(j2,j3)**2+
     .2d0*s(j1,j4)*s(j5,j6)+2d0*s(j2,j3)*s(j5,j6)-s(j5,j6)**2+
     .(s(j1,j4)-s(j2,j3)-s(j5,j6))*(t(j1,j2,j3)-t(j2,j3,j4)))
     .)/(za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4))))/
     .(2d0*(s(j1,j4)**2-2d0*s(j1,j4)*s(j2,j3)+s(j2,j3)**2-
     .2d0*s(j1,j4)*s(j5,j6)-2d0*s(j2,j3)*s(j5,j6)+s(j5,j6)**2)*za(j1,j2)
     .*
     .(za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4)))
      fac=fac+
     .(I3m(s(j2,j3),s(j1,j4),s(j5,j6))*za(j2,j3)*
     .((-3d0*za(j1,j4)*(za(j2,j4)*zb(j1,j2)+za(j3,j4)*zb(j1,j3))*
     .zb(j2,j3)*((s(j1,j4)-s(j2,j3)-s(j5,j6))*za(j1,j3)*
     .zb(j1,j4)-
     .(-s(j1,j4)+s(j2,j3)-s(j5,j6))*za(j2,j3)*zb(j2,j4))*
     .(-(za(j2,j5)*zb(j2,j6))-za(j3,j5)*zb(j3,j6)))/
     .(s(j1,j4)**2-2d0*s(j1,j4)*s(j2,j3)+s(j2,j3)**2-
     .2d0*s(j1,j4)*s(j5,j6)-2d0*s(j2,j3)*s(j5,j6)+s(j5,j6)**2)**2-
     .(za(j4,j5)*zb(j1,j2)*
     .(za(j1,j2)*zb(j2,j6)+za(j1,j3)*zb(j3,j6)))/t(j1,j2,j3)-
     .(-(za(j3,j4)*zb(j1,j6)*zb(j2,j3)*
     .((-s(j1,j4)+s(j2,j3)-s(j5,j6))*za(j1,j5)-
     .za(j4,j5)*
     .(za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4))+
     .2d0*za(j1,j4)*za(j5,j6)*zb(j4,j6)))+
     .(za(j2,j4)*zb(j1,j2)+za(j3,j4)*zb(j1,j3))*
     .(-(za(j1,j4)*zb(j2,j4)*
     .(-(za(j2,j5)*zb(j2,j6))-za(j3,j5)*zb(j3,j6)))+
     .3d0*za(j1,j3)*za(j4,j5)*zb(j2,j3)*zb(j4,j6))-
     .za(j4,j5)*zb(j1,j2)*
     .((s(j1,j4)-s(j2,j3)-s(j5,j6))*za(j1,j4)*zb(j4,j6)-
     .(-s(j1,j4)-s(j2,j3)+s(j5,j6))*za(j1,j5)*zb(j5,j6))-
     .(za(j1,j3)*za(j1,j5)*zb(j2,j3)*
     .(za(j2,j4)*zb(j1,j2)*zb(j4,j6)+
     .za(j3,j4)*zb(j1,j3)*zb(j4,j6))*
     .(-t(j1,j2,j3)+t(j2,j3,j4)))/
     .(za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4)))/
     .(s(j1,j4)**2-2d0*s(j1,j4)*s(j2,j3)+s(j2,j3)**2-
     .2d0*s(j1,j4)*s(j5,j6)-2d0*s(j2,j3)*s(j5,j6)+s(j5,j6)**2)))/
     .(za(j1,j2)*(za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4)))

      Fsc4=Fsc4+za(j1,j3)/za(j2,j3)*fac

      return
      end

ext: f

max_stars_repo_name: tmartini/JHUGen

max_issues_repo_name: tmartini/JHUGen

max_forks_repo_name: tmartini/JHUGen


module spline
!! Spline utilities
implicit none

private :: findIdx

contains

subroutine cubspline_init(n, x, y,y2)
  !! Initialize a cubic spline
  integer, intent(in) :: n !! data length
  real(8), intent(in) :: x(n) !! x input data
  real(8), intent(in) :: y(n) !! y(x)
  real(8), intent(out) :: y2(n) !! spline data

  integer :: i,k
  real(8) :: p,qn,sig, un,u(n), yp1,yp2,h

  h = x(2)-x(1)

  y2(1)=0.d0
  u(1)=0.d0
  do i=2,n-1
    sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
    p=sig*y2(i-1)+2.d0
    y2(i)=(sig-1.d0)/p
    yp1=(y(i+1)-y(i))/(x(i+1)-x(i))
    yp2=(y(i)-y(i-1))/(x(i)-x(i-1))
    u(i)=(6.d0*(yp1-yp2)/(x(i+1)-x(i-1))-sig*u(i-1))/p
  end do
  qn=0.d0
  un=0.d0
  y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.d0)
  do k=n-1,1,-1
    y2(k) = y2(k)*y2(k+1) + u(k)
  end do

end subroutine

function cubspline_equalsep_eval_single_nchk(hi, h2sur6,xmin,y,y2, val) result(res)
  !! Evaluate a spline of equally sperated absissa at `val`. Input range is not checked. Helper function.
  real(8) :: res
  real(8), intent(in) :: y(*) !! y(x) data points
  real(8), intent(in) :: y2(*) !! spline data
  real(8), intent(in) :: val  !! value
  real(8), intent(in) :: hi !! 1/h,  where h is step
  real(8), intent(in) :: h2sur6 !! h^2/6, where h is step
  real(8), intent(in) :: xmin !! minimum x value
  integer :: nr2
  real(8) :: a,b

  a=(val-xmin)*hi
  nr2=int(a)
  a = a - real(nr2,8)
  b=1.d0-a
  res=y(nr2+2)*a+y(nr2+1)*b+&
    &(y2(nr2+2)*a*(a*a-1.d0)+y2(nr2+1)*b*(b*b-1.d0))*h2sur6
end function

subroutine cubspline_equalsep_eval(n, x, y, y2, nnew,xnew, ynew)
  !! Evaluates an array of values.
  integer, intent(in) :: n !! data length
  real(8), intent(in) :: x(n) !! input values
  real(8), intent(in) :: y(n) !! y(x) data values
  real(8), intent(in) :: y2(n) !! spline data
  integer, intent(in) :: nnew !! output data length
  real(8), intent(in) :: xnew(nnew) !! values to be evaluated
  real(8), intent(out) :: ynew(nnew) !! result array y(xnew)

  integer :: i,imin, imax
  real(8) :: h2s6,hi,h
  h = x(2) - x(1)
  h2s6 = h*h/6.d0
  hi = 1.d0 / h

  do imin=1,nnew
    if(xnew(imin) > x(1)) exit
    ynew(imin) = y(1)
  end do
  do imax=nnew,1,-1
    if(xnew(imax) < x(n)) exit
    ynew(imax) = y(n)
  end do

  do i=imin,imax
    ynew(i) = cubspline_equalsep_eval_single_nchk(hi, h2s6,x(1),y,y2, xnew(i))
  end do

end subroutine

integer function findIdx(n, x, val)
  !todo: store klo, khi for sequential calls
  integer, intent(in) :: n
  real(8), intent(in) :: x(n)
  real(8), intent(in) :: val
  integer :: klo, khi,k
  klo = 1
  khi = n
  do while(khi-klo>1)
    k=(khi+klo) / 2
    if(x(k) > val) then
      khi = k
    else
      klo=k
    end if
  end do
  findIdx= klo
end function

real(8) function cubspline_eval(n, x, y, y2, val)
  !! Evaluates a value. `val` must be in range.
  integer, intent(in) :: n !! data length
  real(8), intent(in) :: x(n) !! input values
  real(8), intent(in) :: y(n) !! y(x) data values
  real(8), intent(in) :: y2(n) !! spline data
  real(8), intent(in) :: val !! value

  integer :: nr2
  real(8) :: a,dx,b,c,d,h2sur6

  nr2 = findIdx(n,x, val)
  dx = x(nr2+1) - x(nr2)
  a = (val - x(nr2))/dx
  b = 1.0d0 - a
  c = a*(a*a-1.0d0)
  d = b*(b*b - 1.0d0)
  h2sur6 = dx*dx*(1.0d0/6.0d0)
  cubspline_eval = y(nr2 + 1) * a + y(nr2) * b + (y2(nr2 + 1) * c + y2(nr2) * d )* h2sur6

end function

end module


text:
great_ne(jj1,a1).
great_ne(bb1,y1).
great_ne(y1,f1).
great_ne(ee1,a1).
great_ne(ii1,c1).
great_ne(t1,jj1).
great_ne(cc1,ii1).
great_ne(x1,b1).
great_ne(aa1,f1).
great_ne(dd1,i1).
great_ne(u1,ff1).
great_ne(bb1,k1).
great_ne(z1,i1).
great_ne(u1,f1).
great_ne(q1,kk1).
great_ne(jj1,x1).
great_ne(w1,h1).
great_ne(q1,t1).
great_ne(m1,w1).
great_ne(u1,ii1).
great_ne(q1,ee1).
great_ne(u1,m1).
great_ne(k1,m1).
great_ne(jj1,ff1).
great_ne(aa1,w1).
great_ne(z1,u1).
great_ne(ee1,i1).
great_ne(v1,ii1).
great_ne(q1,y1).
great_ne(ii1,a1).
great_ne(v1,c1).
great_ne(t1,x1).
great_ne(bb1,m1).
great_ne(t1,ee1).

max_stars_repo_name: manoelfranca/cilppp

max_issues_repo_name: manoelfranca/cilppp

max_forks_repo_name: manoelfranca/cilppp