      SUBROUTINE QPASSF2(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, 
     1                   LA,IERR)     
C   
C     * NOV 01/92 - J.STACEY. OPTIMIZED FOR SX-3 WITH MAX VECTOR 
C     *                       LENGTH NOW 256, INSTEAD OF 64 FOR PREVIOUS
C     *                       VERSION QPASSF.             
C     * APR 17/89 - F.MAJAESS (ADJUST CODES FOR CRAY AS IN ECMWF FFT991)
C         
C     SUBROUTINE 'QPASSF2' - PERFORMS ONE PASS THROUGH DATA AS PART 
C     OF MULTIPLE REAL FFT (FOURIER ANALYSIS) ROUTINE   
C         
C     A IS FIRST REAL INPUT VECTOR     
C         EQUIVALENCE B(1) WITH A(IFAC*LA*INC1+1)   
C     C IS FIRST REAL OUTPUT VECTOR     
C         EQUIVALENCE D(1) WITH C(LA*INC2+1)    
C     TRIGS IS A PRECALCULATED LIST OF SINES & COSINES   
C     INC1 IS THE ADDRESSING INCREMENT FOR A    
C     INC2 IS THE ADDRESSING INCREMENT FOR C    
C     INC3 IS THE INCREMENT BETWEEN INPUT VECTORS A   
C     INC4 IS THE INCREMENT BETWEEN OUTPUT VECTORS C   
C     LOT IS THE NUMBER OF VECTORS     
C     N IS THE LENGTH OF THE VECTORS     
C     IFAC IS THE CURRENT FACTOR OF N     
C     LA = N/(PRODUCT OF FACTORS USED SO FAR)    
C     IERR IS AN ERROR INDICATOR:     
C              0 - PASS COMPLETED WITHOUT ERROR    
C              1 - LOT GREATER THAN 64     
C              2 - IFAC NOT CATERED FOR     
C              3 - IFAC ONLY CATERED FOR IF LA=N/IFAC   
C-----------------------------------------------------------------------
C         
      IMPLICIT REAL (A-H,O-Z),
     +INTEGER (I-N)

      DIMENSION A(N),B(N),C(N),D(N),TRIGS(N)    
C         
      DATA SIN36/0.587785252292473/,SIN72/0.951056516295154/,  
     *    QRT5/0.559016994374947/,SIN60/0.866025403784437/  
C         
      M=N/IFAC        
      IINK=LA*INC1       
      JINK=LA*INC2       
      IJUMP=(IFAC-1)*IINK      
      KSTOP=(N-IFAC)/(2*IFAC)      
C         
      IBAD=1        
      IF (LOT .GT. 256) GO TO 910     
      IBASE=0        
      JBASE=0        
      IGO=IFAC-1       
      IF (IGO.EQ.7) IGO=6      
      IBAD=2        
      IF (IGO.LT.1.OR.IGO.GT.6) GO TO 910    
      GO TO (200,300,400,500,600,800),IGO    
C         
C     CODING FOR FACTOR 2      
C     -------------------      
  200 CONTINUE        
      IA=1        
      IB=IA+IINK       
      JA=1        
      JB=JA+(2*M-LA)*INC2      
C         
      IF (LA.EQ.M) GO TO 290      
C         
      DO 220 L=1,LA       
      I=IBASE        
      J=JBASE        
*vdir nodep        
      DO 210 IJK=1,LOT       
      C(JA+J)=A(IA+I)+A(IB+I)      
      C(JB+J)=A(IA+I)-A(IB+I)      
      I=I+INC3        
      J=J+INC4        
  210 CONTINUE        
      IBASE=IBASE+INC1       
      JBASE=JBASE+INC2       
  220 CONTINUE        
      JA=JA+JINK       
      JINK=2*JINK       
      JB=JB-JINK       
      IBASE=IBASE+IJUMP       
      IJUMP=2*IJUMP+IINK      
      IF (JA.EQ.JB) GO TO 260      
      DO 250 K=LA,KSTOP,LA      
      KB=K+K        
      C1=TRIGS(KB+1)       
      S1=TRIGS(KB+2)       
      JBASE=0        
      DO 240 L=1,LA       
      I=IBASE        
      J=JBASE        
*vdir nodep        
      DO 230 IJK=1,LOT       
      C(JA+J)=A(IA+I)+(C1*A(IB+I)+S1*B(IB+I))    
      C(JB+J)=A(IA+I)-(C1*A(IB+I)+S1*B(IB+I))    
      D(JA+J)=(C1*B(IB+I)-S1*A(IB+I))+B(IA+I)    
      D(JB+J)=(C1*B(IB+I)-S1*A(IB+I))-B(IA+I)    
      I=I+INC3        
      J=J+INC4        
  230 CONTINUE        
      IBASE=IBASE+INC1       
      JBASE=JBASE+INC2       
  240 CONTINUE        
      IBASE=IBASE+IJUMP       
      JA=JA+JINK       
      JB=JB-JINK       
  250 CONTINUE        
      IF (JA.GT.JB) GO TO 900      
  260 CONTINUE        
      JBASE=0        
      DO 280 L=1,LA       
      I=IBASE        
      J=JBASE        
*vdir nodep        
      DO 270 IJK=1,LOT       
      C(JA+J)=A(IA+I)       
      D(JA+J)=-A(IB+I)       
      I=I+INC3        
      J=J+INC4        
  270 CONTINUE        
      IBASE=IBASE+INC1       
      JBASE=JBASE+INC2       
  280 CONTINUE        
      GO TO 900        
C         
  290 CONTINUE        
      Z=1.0/FLOAT(N)       
      DO 294 L=1,LA       
      I=IBASE        
      J=JBASE        
*vdir nodep        
      DO 292 IJK=1,LOT       
      C(JA+J)=Z*(A(IA+I)+A(IB+I))     
      C(JB+J)=Z*(A(IA+I)-A(IB+I))     
      I=I+INC3        
      J=J+INC4        
  292 CONTINUE        
      IBASE=IBASE+INC1       
      JBASE=JBASE+INC2       
  294 CONTINUE        
      GO TO 900        
C         
C     CODING FOR FACTOR 3      
C     -------------------      
  300 CONTINUE        
      IA=1        
      IB=IA+IINK       
      IC=IB+IINK       
      JA=1        
      JB=JA+(2*M-LA)*INC2      
      JC=JB        
C         
      IF (LA.EQ.M) GO TO 390      
C         
      DO 320 L=1,LA       
      I=IBASE        
      J=JBASE        
*vdir nodep        
      DO 310 IJK=1,LOT       
      C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I))     
      C(JB+J)=A(IA+I)-0.5*(A(IB+I)+A(IC+I))    
      D(JB+J)=SIN60*(A(IC+I)-A(IB+I))     
      I=I+INC3        
      J=J+INC4        
  310 CONTINUE        
      IBASE=IBASE+INC1       
      JBASE=JBASE+INC2       
  320 CONTINUE        
      JA=JA+JINK       
      JINK=2*JINK       
      JB=JB+JINK       
      JC=JC-JINK       
      IBASE=IBASE+IJUMP       
      IJUMP=2*IJUMP+IINK      
      IF (JA.EQ.JC) GO TO 360      
      DO 350 K=LA,KSTOP,LA      
      KB=K+K        
      KC=KB+KB        
      C1=TRIGS(KB+1)       
      S1=TRIGS(KB+2)       
      C2=TRIGS(KC+1)       
      S2=TRIGS(KC+2)       
      JBASE=0        
      DO 340 L=1,LA       
      I=IBASE        
      J=JBASE        
*vdir nodep        
      DO 330 IJK=1,LOT       
      A1=(C1*A(IB+I)+S1*B(IB+I))+(C2*A(IC+I)+S2*B(IC+I))  
      B1=(C1*B(IB+I)-S1*A(IB+I))+(C2*B(IC+I)-S2*A(IC+I))  
      A2=A(IA+I)-0.5*A1       
      B2=B(IA+I)-0.5*B1       
      A3=SIN60*((C1*A(IB+I)+S1*B(IB+I))-(C2*A(IC+I)+S2*B(IC+I))) 
      B3=SIN60*((C1*B(IB+I)-S1*A(IB+I))-(C2*B(IC+I)-S2*A(IC+I))) 
      C(JA+J)=A(IA+I)+A1      
      D(JA+J)=B(IA+I)+B1      
      C(JB+J)=A2+B3       
      D(JB+J)=B2-A3       
      C(JC+J)=A2-B3       
      D(JC+J)=-(B2+A3)       
      I=I+INC3        
      J=J+INC4        
  330 CONTINUE        
      IBASE=IBASE+INC1       
      JBASE=JBASE+INC2       
  340 CONTINUE        
      IBASE=IBASE+IJUMP       
      JA=JA+JINK       
      JB=JB+JINK       
      JC=JC-JINK       
  350 CONTINUE        
      IF (JA.GT.JC) GO TO 900      
  360 CONTINUE        
      JBASE=0        
      DO 380 L=1,LA       
      I=IBASE        
      J=JBASE        
*vdir nodep        
      DO 370 IJK=1,LOT       
      C(JA+J)=A(IA+I)+0.5*(A(IB+I)-A(IC+I))    
      D(JA+J)=-SIN60*(A(IB+I)+A(IC+I))     
      C(JB+J)=A(IA+I)-(A(IB+I)-A(IC+I))     
      I=I+INC3        
      J=J+INC4        
  370 CONTINUE        
      IBASE=IBASE+INC1       
      JBASE=JBASE+INC2       
  380 CONTINUE        
      GO TO 900        
C         
  390 CONTINUE        
      Z=1.0/FLOAT(N)       
      ZSIN60=Z*SIN60       
      DO 394 L=1,LA       
      I=IBASE        
      J=JBASE        
*vdir nodep        
      DO 392 IJK=1,LOT       
      C(JA+J)=Z*(A(IA+I)+(A(IB+I)+A(IC+I)))    
      C(JB+J)=Z*(A(IA+I)-0.5*(A(IB+I)+A(IC+I)))    
      D(JB+J)=ZSIN60*(A(IC+I)-A(IB+I))     
      I=I+INC3        
      J=J+INC4        
  392 CONTINUE        
      IBASE=IBASE+INC1       
      JBASE=JBASE+INC2       
  394 CONTINUE        
      GO TO 900        
C         
C     CODING FOR FACTOR 4      
C     -------------------      
  400 CONTINUE        
      IA=1        
      IB=IA+IINK       
      IC=IB+IINK       
      ID=IC+IINK       
      JA=1        
      JB=JA+(2*M-LA)*INC2      
      JC=JB+2*M*INC2       
      JD=JB        
C         
      IF (LA.EQ.M) GO TO 490      
C         
      DO 420 L=1,LA       
      I=IBASE        
      J=JBASE        
*vdir nodep        
      DO 410 IJK=1,LOT       
      C(JA+J)=(A(IA+I)+A(IC+I))+(A(IB+I)+A(ID+I))   
      C(JC+J)=(A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I))   
      C(JB+J)=A(IA+I)-A(IC+I)      
      D(JB+J)=A(ID+I)-A(IB+I)      
      I=I+INC3        
      J=J+INC4        
  410 CONTINUE        
      IBASE=IBASE+INC1       
      JBASE=JBASE+INC2       
  420 CONTINUE        
      JA=JA+JINK       
      JINK=2*JINK       
      JB=JB+JINK       
      JC=JC-JINK       
      JD=JD-JINK       
      IBASE=IBASE+IJUMP       
      IJUMP=2*IJUMP+IINK      
      IF (JB.EQ.JC) GO TO 460      
      DO 450 K=LA,KSTOP,LA      
      KB=K+K        
      KC=KB+KB        
      KD=KC+KB        
      C1=TRIGS(KB+1)       
      S1=TRIGS(KB+2)       
      C2=TRIGS(KC+1)       
      S2=TRIGS(KC+2)       
      C3=TRIGS(KD+1)       
      S3=TRIGS(KD+2)       
      JBASE=0        
      DO 440 L=1,LA       
      I=IBASE        
      J=JBASE        
*vdir nodep        
      DO 430 IJK=1,LOT       
      A0=A(IA+I)+(C2*A(IC+I)+S2*B(IC+I))    
      A2=A(IA+I)-(C2*A(IC+I)+S2*B(IC+I))    
      A1=(C1*A(IB+I)+S1*B(IB+I))+(C3*A(ID+I)+S3*B(ID+I))  
      A3=(C1*A(IB+I)+S1*B(IB+I))-(C3*A(ID+I)+S3*B(ID+I))  
      B0=B(IA+I)+(C2*B(IC+I)-S2*A(IC+I))    
      B2=B(IA+I)-(C2*B(IC+I)-S2*A(IC+I))    
      B1=(C1*B(IB+I)-S1*A(IB+I))+(C3*B(ID+I)-S3*A(ID+I))  
      B3=(C1*B(IB+I)-S1*A(IB+I))-(C3*B(ID+I)-S3*A(ID+I))  
      C(JA+J)=A0+A1       
      C(JC+J)=A0-A1       
      D(JA+J)=B0+B1       
      D(JC+J)=B1-B0       
      C(JB+J)=A2+B3       
      C(JD+J)=A2-B3       
      D(JB+J)=B2-A3       
      D(JD+J)=-(B2+A3)       
      I=I+INC3        
      J=J+INC4        
  430 CONTINUE        
      IBASE=IBASE+INC1       
      JBASE=JBASE+INC2       
  440 CONTINUE        
      IBASE=IBASE+IJUMP       
      JA=JA+JINK       
      JB=JB+JINK       
      JC=JC-JINK       
      JD=JD-JINK       
  450 CONTINUE        
      IF (JB.GT.JC) GO TO 900      
  460 CONTINUE        
      SIN45=SQRT(0.5)       
      JBASE=0        
      DO 480 L=1,LA       
      I=IBASE        
      J=JBASE        
*vdir nodep        
      DO 470 IJK=1,LOT       
      C(JA+J)=A(IA+I)+SIN45*(A(IB+I)-A(ID+I))    
      C(JB+J)=A(IA+I)-SIN45*(A(IB+I)-A(ID+I))    
      D(JA+J)=-A(IC+I)-SIN45*(A(IB+I)+A(ID+I))    
      D(JB+J)=A(IC+I)-SIN45*(A(IB+I)+A(ID+I))    
      I=I+INC3        
      J=J+INC4        
  470 CONTINUE        
      IBASE=IBASE+INC1       
      JBASE=JBASE+INC2       
  480 CONTINUE        
      GO TO 900        
C         
  490 CONTINUE        
      Z=1.0/FLOAT(N)       
      DO 494 L=1,LA       
      I=IBASE        
      J=JBASE        
*vdir nodep        
      DO 492 IJK=1,LOT       
      C(JA+J)=Z*((A(IA+I)+A(IC+I))+(A(IB+I)+A(ID+I)))   
      C(JC+J)=Z*((A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I)))   
      C(JB+J)=Z*(A(IA+I)-A(IC+I))     
      D(JB+J)=Z*(A(ID+I)-A(IB+I))     
      I=I+INC3        
      J=J+INC4        
  492 CONTINUE        
      IBASE=IBASE+INC1       
      JBASE=JBASE+INC2       
  494 CONTINUE        
      GO TO 900        
C         
C     CODING FOR FACTOR 5      
C     -------------------      
  500 CONTINUE        
      IA=1        
      IB=IA+IINK       
      IC=IB+IINK       
      ID=IC+IINK       
      IE=ID+IINK       
      JA=1        
      JB=JA+(2*M-LA)*INC2      
      JC=JB+2*M*INC2       
      JD=JC        
      JE=JB        
C         
      IF (LA.EQ.M) GO TO 590      
C         
      DO 520 L=1,LA       
      I=IBASE        
      J=JBASE        
*vdir nodep        
      DO 510 IJK=1,LOT       
      A1=A(IB+I)+A(IE+I)      
      A3=A(IB+I)-A(IE+I)      
      A2=A(IC+I)+A(ID+I)      
      A4=A(IC+I)-A(ID+I)      
      A5=A(IA+I)-0.25*(A1+A2)      
      A6=QRT5*(A1-A2)       
      C(JA+J)=A(IA+I)+(A1+A2)      
      C(JB+J)=A5+A6       
      C(JC+J)=A5-A6       
      D(JB+J)=-SIN72*A3-SIN36*A4     
      D(JC+J)=-SIN36*A3+SIN72*A4     
      I=I+INC3        
      J=J+INC4        
  510 CONTINUE        
      IBASE=IBASE+INC1       
      JBASE=JBASE+INC2       
  520 CONTINUE        
      JA=JA+JINK       
      JINK=2*JINK       
      JB=JB+JINK       
      JC=JC+JINK       
      JD=JD-JINK       
      JE=JE-JINK       
      IBASE=IBASE+IJUMP       
      IJUMP=2*IJUMP+IINK      
      IF (JB.EQ.JD) GO TO 560      
      DO 550 K=LA,KSTOP,LA      
      KB=K+K        
      KC=KB+KB        
      KD=KC+KB        
      KE=KD+KB        
      C1=TRIGS(KB+1)       
      S1=TRIGS(KB+2)       
      C2=TRIGS(KC+1)       
      S2=TRIGS(KC+2)       
      C3=TRIGS(KD+1)       
      S3=TRIGS(KD+2)       
      C4=TRIGS(KE+1)       
      S4=TRIGS(KE+2)       
      JBASE=0        
      DO 540 L=1,LA       
      I=IBASE        
      J=JBASE        
*vdir nodep        
      DO 530 IJK=1,LOT       
      A1=(C1*A(IB+I)+S1*B(IB+I))+(C4*A(IE+I)+S4*B(IE+I))  
      A3=(C1*A(IB+I)+S1*B(IB+I))-(C4*A(IE+I)+S4*B(IE+I))  
      A2=(C2*A(IC+I)+S2*B(IC+I))+(C3*A(ID+I)+S3*B(ID+I))  
      A4=(C2*A(IC+I)+S2*B(IC+I))-(C3*A(ID+I)+S3*B(ID+I))  
      B1=(C1*B(IB+I)-S1*A(IB+I))+(C4*B(IE+I)-S4*A(IE+I))  
      B3=(C1*B(IB+I)-S1*A(IB+I))-(C4*B(IE+I)-S4*A(IE+I))  
      B2=(C2*B(IC+I)-S2*A(IC+I))+(C3*B(ID+I)-S3*A(ID+I))  
      B4=(C2*B(IC+I)-S2*A(IC+I))-(C3*B(ID+I)-S3*A(ID+I))  
      A5=A(IA+I)-0.25*(A1+A2)      
      A6=QRT5*(A1-A2)       
      B5=B(IA+I)-0.25*(B1+B2)      
      B6=QRT5*(B1-B2)       
      A10=A5+A6        
      A20=A5-A6        
      B10=B5+B6        
      B20=B5-B6        
      A11=SIN72*B3+SIN36*B4      
      A21=SIN36*B3-SIN72*B4      
      B11=SIN72*A3+SIN36*A4      
      B21=SIN36*A3-SIN72*A4      
      C(JA+J)=A(IA+I)+(A1+A2)      
      C(JB+J)=A10+A11       
      C(JE+J)=A10-A11       
      C(JC+J)=A20+A21       
      C(JD+J)=A20-A21       
      D(JA+J)=B(IA+I)+(B1+B2)      
      D(JB+J)=B10-B11       
      D(JE+J)=-(B10+B11)      
      D(JC+J)=B20-B21       
      D(JD+J)=-(B20+B21)      
      I=I+INC3        
      J=J+INC4        
  530 CONTINUE        
      IBASE=IBASE+INC1       
      JBASE=JBASE+INC2       
  540 CONTINUE        
      IBASE=IBASE+IJUMP       
      JA=JA+JINK       
      JB=JB+JINK       
      JC=JC+JINK       
      JD=JD-JINK       
      JE=JE-JINK       
  550 CONTINUE        
      IF (JB.GT.JD) GO TO 900      
  560 CONTINUE        
      JBASE=0        
      DO 580 L=1,LA       
      I=IBASE        
      J=JBASE        
*vdir nodep        
      DO 570 IJK=1,LOT       
      A1=A(IB+I)+A(IE+I)      
      A3=A(IB+I)-A(IE+I)      
      A2=A(IC+I)+A(ID+I)      
      A4=A(IC+I)-A(ID+I)      
      A5=A(IA+I)+0.25*(A3-A4)      
      A6=QRT5*(A3+A4)       
      C(JA+J)=A5+A6       
      C(JB+J)=A5-A6       
      C(JC+J)=A(IA+I)-(A3-A4)      
      D(JA+J)=-SIN36*A1-SIN72*A2     
      D(JB+J)=-SIN72*A1+SIN36*A2     
      I=I+INC3        
      J=J+INC4        
  570 CONTINUE        
      IBASE=IBASE+INC1       
      JBASE=JBASE+INC2       
  580 CONTINUE        
      GO TO 900        
C         
  590 CONTINUE        
      Z=1.0/FLOAT(N)       
      ZQRT5=Z*QRT5       
      ZSIN36=Z*SIN36       
      ZSIN72=Z*SIN72       
      DO 594 L=1,LA       
      I=IBASE        
      J=JBASE        
*vdir nodep        
      DO 592 IJK=1,LOT       
      A1=A(IB+I)+A(IE+I)      
      A3=A(IB+I)-A(IE+I)      
      A2=A(IC+I)+A(ID+I)      
      A4=A(IC+I)-A(ID+I)      
      A5=Z*(A(IA+I)-0.25*(A1+A2))     
      A6=ZQRT5*(A1-A2)       
      C(JA+J)=Z*(A(IA+I)+(A1+A2))     
      C(JB+J)=A5+A6       
      C(JC+J)=A5-A6       
      D(JB+J)=-ZSIN72*A3-ZSIN36*A4     
      D(JC+J)=-ZSIN36*A3+ZSIN72*A4     
      I=I+INC3        
      J=J+INC4        
  592 CONTINUE        
      IBASE=IBASE+INC1       
      JBASE=JBASE+INC2       
  594 CONTINUE        
      GO TO 900        
C         
C     CODING FOR FACTOR 6      
C     -------------------      
  600 CONTINUE        
      IA=1        
      IB=IA+IINK       
      IC=IB+IINK       
      ID=IC+IINK       
      IE=ID+IINK       
      IF=IE+IINK       
      JA=1        
      JB=JA+(2*M-LA)*INC2      
      JC=JB+2*M*INC2       
      JD=JC+2*M*INC2       
      JE=JC        
      JF=JB        
C         
      IF (LA.EQ.M) GO TO 690      
C         
      DO 620 L=1,LA       
      I=IBASE        
      J=JBASE        
*vdir nodep        
      DO 610 IJK=1,LOT       
      A11=(A(IC+I)+A(IF+I))+(A(IB+I)+A(IE+I))    
      C(JA+J)=(A(IA+I)+A(ID+I))+A11     
      C(JC+J)=(A(IA+I)+A(ID+I)-0.5*A11)     
      D(JC+J)=SIN60*((A(IC+I)+A(IF+I))-(A(IB+I)+A(IE+I)))  
      A11=(A(IC+I)-A(IF+I))+(A(IE+I)-A(IB+I))    
      C(JB+J)=(A(IA+I)-A(ID+I))-0.5*A11     
      D(JB+J)=SIN60*((A(IE+I)-A(IB+I))-(A(IC+I)-A(IF+I)))  
      C(JD+J)=(A(IA+I)-A(ID+I))+A11     
      I=I+INC3        
      J=J+INC4        
  610 CONTINUE        
      IBASE=IBASE+INC1       
      JBASE=JBASE+INC2       
  620 CONTINUE        
      JA=JA+JINK       
      JINK=2*JINK       
      JB=JB+JINK       
      JC=JC+JINK       
      JD=JD-JINK       
      JE=JE-JINK       
      JF=JF-JINK       
      IBASE=IBASE+IJUMP       
      IJUMP=2*IJUMP+IINK      
      IF (JC.EQ.JD) GO TO 660      
      DO 650 K=LA,KSTOP,LA      
      KB=K+K        
      KC=KB+KB        
      KD=KC+KB        
      KE=KD+KB        
      KF=KE+KB        
      C1=TRIGS(KB+1)       
      S1=TRIGS(KB+2)       
      C2=TRIGS(KC+1)       
      S2=TRIGS(KC+2)       
      C3=TRIGS(KD+1)       
      S3=TRIGS(KD+2)       
      C4=TRIGS(KE+1)       
      S4=TRIGS(KE+2)       
      C5=TRIGS(KF+1)       
      S5=TRIGS(KF+2)       
      JBASE=0        
      DO 640 L=1,LA       
      I=IBASE        
      J=JBASE        
*vdir nodep        
      DO 630 IJK=1,LOT       
      A1=C1*A(IB+I)+S1*B(IB+I)      
      B1=C1*B(IB+I)-S1*A(IB+I)      
      A2=C2*A(IC+I)+S2*B(IC+I)      
      B2=C2*B(IC+I)-S2*A(IC+I)      
      A3=C3*A(ID+I)+S3*B(ID+I)      
      B3=C3*B(ID+I)-S3*A(ID+I)      
      A4=C4*A(IE+I)+S4*B(IE+I)      
      B4=C4*B(IE+I)-S4*A(IE+I)      
      A5=C5*A(IF+I)+S5*B(IF+I)      
      B5=C5*B(IF+I)-S5*A(IF+I)      
      A11=(A2+A5)+(A1+A4)      
      A20=(A(IA+I)+A3)-0.5*A11      
      A21=SIN60*((A2+A5)-(A1+A4))     
      B11=(B2+B5)+(B1+B4)      
      B20=(B(IA+I)+B3)-0.5*B11      
      B21=SIN60*((B2+B5)-(B1+B4))     
      C(JA+J)=(A(IA+I)+A3)+A11      
      D(JA+J)=(B(IA+I)+B3)+B11      
      C(JC+J)=A20-B21       
      D(JC+J)=A21+B20       
      C(JE+J)=A20+B21       
      D(JE+J)=A21-B20       
      A11=(A2-A5)+(A4-A1)      
      A20=(A(IA+I)-A3)-0.5*A11      
      A21=SIN60*((A4-A1)-(A2-A5))     
      B11=(B5-B2)-(B4-B1)      
      B20=(B3-B(IA+I))-0.5*B11      
      B21=SIN60*((B5-B2)+(B4-B1))     
      C(JB+J)=A20-B21       
      D(JB+J)=A21-B20       
      C(JD+J)=A11+(A(IA+I)-A3)      
      D(JD+J)=B11+(B3-B(IA+I))      
      C(JF+J)=A20+B21       
      D(JF+J)=A21+B20       
      I=I+INC3        
      J=J+INC4        
  630 CONTINUE        
      IBASE=IBASE+INC1       
      JBASE=JBASE+INC2       
  640 CONTINUE        
      IBASE=IBASE+IJUMP       
      JA=JA+JINK       
      JB=JB+JINK       
      JC=JC+JINK       
      JD=JD-JINK       
      JE=JE-JINK       
      JF=JF-JINK       
  650 CONTINUE        
      IF (JC.GT.JD) GO TO 900      
  660 CONTINUE        
      JBASE=0        
      DO 680 L=1,LA       
      I=IBASE        
      J=JBASE        
*vdir nodep        
      DO 670 IJK=1,LOT       
      C(JA+J)=(A(IA+I)+0.5*(A(IC+I)-A(IE+I)))+ SIN60*(A(IB+I)-A(IF+I)) 
      D(JA+J)=-(A(ID+I)+0.5*(A(IB+I)+A(IF+I)))-SIN60*(A(IC+I)+A(IE+I)) 
      C(JB+J)=A(IA+I)-(A(IC+I)-A(IE+I))     
      D(JB+J)=A(ID+I)-(A(IB+I)+A(IF+I))     
      C(JC+J)=(A(IA+I)+0.5*(A(IC+I)-A(IE+I)))-SIN60*(A(IB+I)-A(IF+I)) 
      D(JC+J)=-(A(ID+I)+0.5*(A(IB+I)+A(IF+I)))+SIN60*(A(IC+I)+A(IE+I)) 
      I=I+INC3        
      J=J+INC4        
  670 CONTINUE        
      IBASE=IBASE+INC1       
      JBASE=JBASE+INC2       
  680 CONTINUE        
      GO TO 900        
C         
  690 CONTINUE        
      Z=1.0/FLOAT(N)       
      ZSIN60=Z*SIN60       
      DO 694 L=1,LA       
      I=IBASE        
      J=JBASE        
*vdir nodep        
      DO 692 IJK=1,LOT       
      A11=(A(IC+I)+A(IF+I))+(A(IB+I)+A(IE+I))    
      C(JA+J)=Z*((A(IA+I)+A(ID+I))+A11)     
      C(JC+J)=Z*((A(IA+I)+A(ID+I))-0.5*A11)    
      D(JC+J)=ZSIN60*((A(IC+I)+A(IF+I))-(A(IB+I)+A(IE+I)))  
      A11=(A(IC+I)-A(IF+I))+(A(IE+I)-A(IB+I))    
      C(JB+J)=Z*((A(IA+I)-A(ID+I))-0.5*A11)    
      D(JB+J)=ZSIN60*((A(IE+I)-A(IB+I))-(A(IC+I)-A(IF+I)))  
      C(JD+J)=Z*((A(IA+I)-A(ID+I))+A11)     
      I=I+INC3        
      J=J+INC4        
  692 CONTINUE        
      IBASE=IBASE+INC1       
      JBASE=JBASE+INC2       
  694 CONTINUE        
      GO TO 900        
C         
C     CODING FOR FACTOR 8      
C     -------------------      
  800 CONTINUE        
      IBAD=3        
      IF (LA.NE.M) GO TO 910      
      IA=1        
      IB=IA+IINK       
      IC=IB+IINK       
      ID=IC+IINK       
      IE=ID+IINK       
      IF=IE+IINK       
      IG=IF+IINK       
      IH=IG+IINK       
      JA=1        
      JB=JA+LA*INC2       
      JC=JB+2*M*INC2       
      JD=JC+2*M*INC2       
      JE=JD+2*M*INC2       
      Z=1.0/FLOAT(N)       
      ZSIN45=Z*SQRT(0.5)      
C         
      DO 820 L=1,LA       
      I=IBASE        
      J=JBASE        
*vdir nodep        
      DO 810 IJK=1,LOT       
      C(JA+J)=Z*(((A(IA+I)+A(IE+I))+(A(IC+I)+A(IG+I)))+   
     *    ((A(ID+I)+A(IH+I))+(A(IB+I)+A(IF+I))))   
      C(JE+J)=Z*(((A(IA+I)+A(IE+I))+(A(IC+I)+A(IG+I)))-   
     *    ((A(ID+I)+A(IH+I))+(A(IB+I)+A(IF+I))))   
      C(JC+J)=Z*((A(IA+I)+A(IE+I))-(A(IC+I)+A(IG+I)))   
      D(JC+J)=Z*((A(ID+I)+A(IH+I))-(A(IB+I)+A(IF+I)))   
      C(JB+J)=Z*(A(IA+I)-A(IE+I))     
     *    +ZSIN45*((A(IH+I)-A(ID+I))-(A(IF+I)-A(IB+I)))   
      C(JD+J)=Z*(A(IA+I)-A(IE+I))     
     *    -ZSIN45*((A(IH+I)-A(ID+I))-(A(IF+I)-A(IB+I)))   
      D(JB+J)=ZSIN45*((A(IH+I)-A(ID+I))+(A(IF+I)-A(IB+I)))  
     *    +Z*(A(IG+I)-A(IC+I))      
      D(JD+J)=ZSIN45*((A(IH+I)-A(ID+I))+(A(IF+I)-A(IB+I)))  
     *    -Z*(A(IG+I)-A(IC+I))      
      I=I+INC3        
      J=J+INC4        
  810 CONTINUE        
      IBASE=IBASE+INC1       
      JBASE=JBASE+INC2       
  820 CONTINUE        
C         
C     RETURN        
C     ------        
  900 CONTINUE        
      IBAD=0        
  910 CONTINUE        
      IERR=IBAD        
      RETURN        
      END        
