




      SUBROUTINE SUP024 (ISOUP1,ISOUP2,RMAT,TVEC,RMSE,IERR)




















      IMPLICIT      NONE
      INCLUDE       'BIGINC.INC'
      INCLUDE       'VECTOR.INC'
      INTEGER       IFT1,IFT2, JFT1,JFT2, IAT,JAT, IATLOC, JATLOC,
     +              ISOUP1, ISOUP2, IERR
      REAL          RMAT(3,3), TVEC(3), RMSE
      LOGICAL       GVFRIN







      IERR=1
      IFT1=SOUADM(1,ISOUP1)
      IFT2=SOUADM(2,ISOUP1)
      JFT1=SOUADM(1,ISOUP2)
      JFT2=SOUADM(2,ISOUP2)
      IF (IFT2-IFT1.LE.0) GOTO 998
      IF (JFT2-JFT1.LE.0) GOTO 998
      IF (.NOT.GVFRIN(FLOAT(SOUADM(3,ISOUP1))/
     + FLOAT(SOUADM(3,ISOUP2)),0.75,1.25)) GOTO 998
      IERR=0



      DO 10 JAT=PNTAAS(JFT1),PNTAAE(JFT2)
         JATLOC=JAT-PNTAAS(JFT1)+1
         XMOL(1,JATLOC)=XCOORD(JAT)
         XMOL(2,JATLOC)=YCOORD(JAT)
         XMOL(3,JATLOC)=ZCOORD(JAT)
   10 CONTINUE



      CALL SUP025 (IFT1,IFT2,JFT1,JFT2,IERR)



      IF (IERR.EQ.0) THEN
         CALL WIFPUSHPPP (82,150)
         CALL WIFPUSHPPP (83,100)
         CALL SUP026 (IFT1,IFT2,JFT1,JFT2,RMAT,TVEC,RMSE,IERR)
         CALL WIFPOPPPP (83)
         CALL WIFPOPPPP (82)
      END IF



      DO 20 IAT=PNTAAS(SOUADM(1,ISOUP2)),PNTAAE(SOUADM(2,ISOUP2))
         IATLOC=IAT-PNTAAS(SOUADM(1,ISOUP2))+1
         XCOORD(IAT)=XMOL(1,IATLOC)
         YCOORD(IAT)=XMOL(2,IATLOC)
         ZCOORD(IAT)=XMOL(3,IATLOC)
   20 CONTINUE



  998 CONTINUE


      RETURN
      END
      SUBROUTINE SUP025 (IFT1,IFT2,JFT1,JFT2,IERR)

















      IMPLICIT      NONE
      INCLUDE       'BIGINC.INC'
      INCLUDE       'MAPINC.INC'
      INCLUDE       'WALIGN.INC'
      INCLUDE       'ESPACE.INC'
      INTEGER       IDIFF, IERR, IFT1, IFT2, JFT1,
     +              JFT2, LENSTART, LOCIAA, IAATYP, IAA,
     +              JAA, LOCJAA, I, LENTOT, SEQDIF
      REAL          AMAT(MAXBAA,MAXBAA), RSARAY(2*((MAXBAA+1)**2)),
     +              BSTDUM
      EQUIVALENCE   (ESPACE(10001),RSARAY(1))
      EQUIVALENCE   (AMAT(1,1),ALLGRD(1))

      RETURN
      END
      SUBROUTINE SUP026 (IFT1,IFT2,JFT1,JFT2,RMAT,TVEC,RMSE,IERR)




















      IMPLICIT      NONE
      INCLUDE       'BIGINC.INC'
      INCLUDE       'ESPACE.INC'
      INCLUDE       'SUPPOS.INC'
      INTEGER       IFT1,IFT2, JFT1,JFT2, IAT,JAT, ICNT, IBIN, I,J, 
     +              IPNT, IAA,JAA, NUMUSE,NUMNOT, IROUND, IERR
      REAL          RMAT(3,3), TVEC(3), RMSE, QEM,
     +              D, EMAX, OLDRMS, WIFDST, DETMAT, GVFDET







      CALL WIF664
      IERR=0
      QEM=WIFPAR(82)/100.0
      CALL GVSITC (ISET1,1,MAXAA)
      OLDRMS=999.9



      DO 300 IROUND=1,5
         IPNT=0
         DO 10 IAA=IFT1,IFT2
            IF (ISET1(IAA).EQ.0) GOTO 10
            IPNT=IPNT+1
            IRNG1(IPNT)=IAA
            XRNG1(1,IPNT)=XCOORD(PNTAAC(IAA))
            XRNG1(2,IPNT)=YCOORD(PNTAAC(IAA))
            XRNG1(3,IPNT)=ZCOORD(PNTAAC(IAA))
   10    CONTINUE



         IPNT=0
         DO 20 JAA=JFT1,JFT2
            IF (ISET1(JAA).EQ.0) GOTO 20
            IPNT=IPNT+1
            IRNG2(IPNT)=JAA
            XRNG2(1,IPNT)=XCOORD(PNTAAC(JAA))
            XRNG2(2,IPNT)=YCOORD(PNTAAC(JAA))
            XRNG2(3,IPNT)=ZCOORD(PNTAAC(JAA))
   20    CONTINUE



         IF (IPNT.LT.3) THEN
            IERR=1
            GOTO 900
         END IF
         CALL GVSSPN (IPNT,XRNG1,XRNG2,SUPMAT,SUPVEC,RMSE,EMAX)
         DETMAT=GVFDET(SUPMAT)
         IF (ABS(1.0-DETMAT).GT.0.002) THEN
            DO 23 I=1,IPNT
               CALL GVSFMT ('?FMT1377')
               WRITE (6,FMT,ERR=900) I,(XRNG1(J,I),J=1,3),
     +          (XRNG2(J,I),J=1,3)
   23       CONTINUE
            CALL GVSTT6 ('?NEWT782')
            WRITE (6,*,ERR=900) IFT1,IFT2,JFT1,JFT2,IPNT,RMSE
            CALL GVSTTB ('?NEWB328')
            CALL GVSWM4 (SUPMAT,SUPVEC)
         END IF



         CALL WIF092 (JFT1,JFT2,SUPMAT,SUPVEC)



         CALL GVSIT0 (ISET1,MAXAA)
         ICNT=0
         DO 100 IAA=IFT1,IFT2
            JAA=IAA-IFT1+JFT1
            D=WIFDST(PNTAAC(IAA),PNTAAC(JAA))
            IF (D.LT.QEM) THEN
               ISET1(IAA)=1
               ISET1(JAA)=1
               ICNT=ICNT+1
            END IF
  100    CONTINUE



         IF (ABS(OLDRMS-RMSE).LT.0.001.OR.RMSE.LT.0.1) GOTO 301
         IF (IROUND.LT.5) CALL WIF093 (JFT1,JFT2,SUPMAT,SUPVEC)
  300 CONTINUE
  301 CONTINUE



      CALL GVSCPR (RMAT,SUPMAT,9)
      CALL GVSCPR (TVEC,SUPVEC,3)



      NUMUSE=0
      NUMNOT=0
      DO 200 IAA=IFT1,IFT2
         JAA=JFT1+IAA-IFT1
         IF (WIFDST(PNTAAC(IAA),PNTAAC(JAA)).LE.QEM) THEN
            NUMUSE=NUMUSE+1
         ELSE
            NUMNOT=NUMNOT+1
         END IF
         DO 190 IAT=PNTAAS(IAA),PNTAAE(IAA)
            JAT=PNTAAS(JAA)+PINIAA(IAT)-1
            IBIN=MIN(100,NINT(WIFDST(IAT,JAT)*10.0))+1
  190    CONTINUE
  200 CONTINUE



      IF (FLOAT(NUMNOT).GT.0.3*FLOAT(NUMUSE+NUMNOT)) THEN
         IF (WIFPAR(279).LE.0) CALL GVSTT6 ('?NEWT783')
         IERR=1
      END IF



      DETMAT=GVFDET(SUPMAT)
      IF (ABS(1.0-DETMAT).GT.0.002) THEN
         CALL GVSTTB ('?NEWB329')
         CALL GVSWM4 (SUPMAT,SUPVEC)
      END IF
      CALL WIF093 (JFT1,JFT2,SUPMAT,SUPVEC)



  900 CONTINUE


      RETURN
      END
      SUBROUTINE SUP026A (IFT1,IFT2,JFT1,RMSE,IERR)




















      IMPLICIT      NONE
      INCLUDE       'BIGINC.INC'
      INCLUDE       'ESPACE.INC'
      INCLUDE       'SUPPOS.INC'
      INTEGER       IFT1,IFT2, JFT1, IPNT, IAA, JAA, IERR
      REAL          RMSE, EMAX







      CALL WIF664
      IERR=0
      IPNT=0
      CALL GVSITC (ISET1,1,MAXAA)



      DO 10 IAA=IFT1,IFT2
         JAA=IAA-IFT1+JFT1
         IPNT=IPNT+1
         IRNG1(IPNT)=IAA
         IRNG2(IPNT)=JAA
         XRNG1(1,IPNT)=XCOORD(PNTAAC(IAA))
         XRNG1(2,IPNT)=YCOORD(PNTAAC(IAA))
         XRNG1(3,IPNT)=ZCOORD(PNTAAC(IAA))
         XRNG2(1,IPNT)=XCOORD(PNTAAC(JAA))
         XRNG2(2,IPNT)=YCOORD(PNTAAC(JAA))
         XRNG2(3,IPNT)=ZCOORD(PNTAAC(JAA))
   10 CONTINUE



      CALL GVSSPN (IPNT,XRNG1,XRNG2,SUPMAT,SUPVEC,RMSE,EMAX)





      RETURN
      END
