*
* $Id: siquad.F,v 1.1.1.1 1995/12/12 14:36:20 mclareni Exp $
*
* $Log: siquad.F,v $
* Revision 1.1.1.1  1995/12/12 14:36:20  mclareni
* Imported sources
*
*
#include "sigma/pilot.h"
*CMZ :  1.09/02 06/08/93  17.15.25  by  Carlo E. Vandoni
*-- Author :
      SUBROUTINE SIQUAD
C
C
C    ..................................................
C
C
C         PURPOSE
C            TO INTEGRATE EACH ROW OF FIRST ARGUMENT WITH STEP SIZE
C            GIVEN BY THE SECOND ARGUMENT
C
C         USAGE
C            CALL QUAD
C
C         TRACKS USED
C
C         COMM. BLOCKS USED
C            COM1
C
C         REMARKS
C            Z=QUAD(Y,X)
C            C=QUAD(A,B)
C
C            INTEGRATES EACH ROW INDEPENDENTLY
C            FIRST ARG MUST HAVE AT LEAST 5 ELEMENTS PER ROW
C            SECOND ARG MUST BE A SCALAR
C
C            FOR COMPLEX 1-ST ARG QUAD INTEGRATES THE REAL AND
C            IMAGINARY PARTS INDEPENDENTLY WITH RESPECT TO THE
C            STEP SIZE  H.
C
C            IF 2-ND ARG IS COMPLEX,ITS IMAGINARY PART IS IGNORED
C
C         SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C            NGET
C            IGETT2
C            SISTR2
C
C         METHOD
C            FOR FIRST POINT INT(1)=0 FIXING THE INTEGRATION CONSTANT
C            FOR THE SECOND AND THIRD POINT
C            INT(I+1)=H*(9*F(I)+19*F(I+1)-5*F(I+2)+F(I+3))/24
C            FOR ALL SUBSEQUENT POINTS
C            INT(I)=H*(F(I-3)-5*F(I-2)+19*F(I-1)+9*F(I))/24
C
C         AUTHOR.   JURIS REINFELDS      DATE 02/08/74
C
C
C...  PAW VERSION  ...  MAY 1988
C
C
C    ..................................................
C
C
#include "sigma/sicsig.inc"
#include "sigma/sigc.inc"
#include "sigma/pawc.inc"
#include "sigma/siclin.inc"
C
C
      DIMENSION DIM(10)
C
C
      CALL SITRAC(' SIQUAD    ')
C
C   IF EITHER OR BOTH ARGUMENTS ARE MISSING INDICES
      DO 33 J=1,2
      CALL SISTAK(J-1,MP,MN)
      IF(MN.EQ.MISIDX) GOTO 918
  33  CONTINUE
      DIM(1)=0.0
C
C
C   IF STEPSIZE NOT A SCALAR VALUE
      CALL SINGET(ISI,0,DIM)
      IF(IERRNO.NE.0)RETURN
      IF(LENGTH.GT.1) CALL SINERR(55)
      IF(IERRNO.NE.0)RETURN

      STEP=DYNA(IADDR)
C
C
C   CONSIDER FIRST ARGUMENT, IF IT IS SOURCE CODE
      DIM(1)=1.0
      CALL SINGET(ISI,1,DIM)
      IF(IERRNO.NE.0)RETURN
      IF(ISI.GE.3) CALL SINERR(56)
      IF(IERRNO.NE.0)RETURN

      LA1=IADDR
      LENROW=DIM(1)
      NROW=LENGTH/LENROW/MODE
C   QUDRATURE NEEDS A ROWLENGTH OF 5 OR MORE
      IF(LENROW.LT.5) CALL SINERR(57)
C
      IF(IERRNO.NE.0)RETURN

C
C
C   GET AREA FOR ANSWER. MODE ALREADY SET BY NGET(1... ABOVE
      ISTRI=0
       CALL SIGTT2(IADDR,LENGTH+NDIM,NDIM,DIM)
      IF(IERRNO.NE.0)RETURN
      LA2=IADDR
C
C
C   INTEGRATE EACH ROW OF THE FIRST ARGUMENT
      DO 100 I=1,NROW
C
C   SET FIRST ELEMENT TO ZERO
      DYNA(LA2)=0.
      IF(MODE.EQ.2) DYNA(LA2+1)=0.
      LA2=LA2+MODE
C
C   SET NEXT TWO ELEMENTS WITH FORWARD FORMULA
      DO 200 J=1,2
      DYNA(LA2)=DYNA(LA2-MODE)+STEP/24.*(9.*DYNA(LA1)+19.*DYNA
     ,(LA1+MODE)-5.*DYNA(LA1+2*MODE)+DYNA(LA1+3*MODE))
      LA2=LA2+MODE
      LA1=LA1+MODE
C
C   IF REAL, SKIP THE QUADRATURE OF THE REAL PART
      IF(MODE.EQ.1) GOTO 200
      DYNA(LA2-1)=DYNA(LA2-3)+STEP/24.*(9.*DYNA(LA1-1)+19.*DYNA
     ,(LA1+1)-5.*DYNA(LA1+3)+DYNA(LA1+5))
C
200   CONTINUE
C
C
C   SET REMAINING ELEMENTS WITH BACKWARD FORMULA
      LA1=LA1+MODE
      DO 210 J=4,LENROW
      DYNA(LA2)=DYNA(LA2-MODE)+STEP/24.*(DYNA(LA1-3*MODE)
     ,-5.*DYNA(LA1-2*MODE)+19.*DYNA(LA1-MODE)+9.*DYNA(LA1))
      LA2=LA2+MODE
      LA1=LA1+MODE
C
C   IF REAL, SKIP THE QUADRATURE OF THE IMAGIMARY PART
      IF(MODE.EQ.1) GOTO 210
      DYNA(LA2-1)=DYNA(LA2-3)+STEP/24.*(DYNA(LA1-7)
     ,-5.*DYNA(LA1-5)+19.*DYNA(LA1-3)+9.*DYNA(LA1-1))
C
210   CONTINUE
C
100   CONTINUE
C
C
C   IADDR IS UNCHANGED, FURTHERMORE A SCALAR RESULT IS IMPOSSIBLE
      CALL SISTR2(2)
C
C
      RETURN
C
C
918   CONTINUE
C   MISSING INDEX MEANINGLESS
      CNAME='QUAD    '
      CALL SINERR(18)
C
C
 999  END