Télécharger racpol.eso

Retour à la liste

racpol
C RACPOL    SOURCE    GF238795  18/02/05    21:15:46     9726           
      SUBROUTINE RACPOL
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
-INC SMLREEL
      DIMENSION Q(4)
      CHARACTER*3 MOTI
      CHARACTER*4 MOT(3)
      data mot/'IMAG','BAIR','INTE'/
      MLREEI=0
      NROOT=0
      imeth=2
      ireel=1
*       write(6,*) ' entree dans racpol'
1      call lirmot ( mot ,3, iret, 0)
      if(iret.eq.1) then
       ireel=0
      elseif(iret.eq.2) then
       imeth=1
      elseif(iret.eq.3) then
       call lirree(xva1,1,iretou)
       if( ierr.ne.0) return
       call lirree(xva2,1,iretou)
       if( ierr.ne.0) return
       imeth=3
      endif
      if(iret.eq.0) go to 25
      go to 1
   25  continue
      CALL LIRREE(U0,0,IRETOU)
      kerre=0
      if( iretou.eq.0) then
         call lirobj('LISTREEL',mlree1,1,iretou)
         if(ierr.ne.0) return
          segact mlree1
*         write(6,*)(mlree1.prog(iu),iu=1,mlree1.prog(/1))
         if(imeth.eq.2) then
*         write(6,*) ' appel de prlagu'
         call prlagu(mlree1,mlreel,mlreei,ireel,kerre)
*           write(6,*) ' sortie de prlagu'
          if(kerre.ne.0) then
            call erreur ( kerre)
            return
          endif
         elseif(imeth.eq.1) then
*          write(6,*) ' appel a bairst'
           call bairst(mlree1,mlreel,mlreei,ireel,kerre)
           if(kerre.ne.0) call erreur ( kerre)
         elseif(imeth.eq.3) then
           call cherac(mlree1,xraci,xva1,xva2)
           if(ierr.ne.0) return
           if( xraci.ne.-1234567.d0) then
             call ecrree(xraci)
           else
             call ecrcha('VIDE')
           endif
           return
         endif
         if(ierr.ne.0) return
         go to 100
      endif
*      write(6,*) ' passage ancienne methode'
      CALL LIRREE(U1,1,IRETOU)
      IF(IERR.NE.0) RETURN
      NDEG=1
      CALL LIRREE(U2,0,IRETOU)
      IF(IRETOU.EQ.0) GO TO 10
      NDEG=2
      CALL LIRREE(U3,0,IRETOU)
      IF(IRETOU.EQ.0) GO TO 20
      NDEG=3
      CALL LIRREE(U4,0,IRETOU)
      IF(IRETOU.EQ.0) GO TO 30
      NDEG=4
C
C  cas du polynome du quatrieme degré
C
      IF(U4.EQ.0.D0) GO TO 30
*      write(6,*) ' appel de quarti'
      CALL QUARTI(U4, U3, U2, U1,U0, Q(1), Q(2), Q(3), Q(4), NRoot)
*      write(6,*) ' sortie de quarti'
      GO TO 50
C
C  cas du polynome du troisieme degré
C
  30  CONTINUE
      IF(U3.EQ.0.D0) GO TO 20
      CALL CUBIC(U3, U2, U1, U0, Q(1), Q(2), Q(3), NRoot)
      GO TO 50
C
C  cas du polynome du deuxieme degré
C
  20  CONTINUE
      IF(U2.EQ.0.D0) GO TO 10
      CALL QUADRA(U2, U1, U0, Q(1), Q(2), NRoot)
      GO TO 50
C
C  cas du polynome du premier degré
C
  10  CONTINUE
         IF(U1.EQ.0) THEN
            CALL ERREUR(21)
            RETURN
         ENDIF
         NROOT=1
         Q(1) = -U0 / U1
  50  CONTINUE
C
C  sortie des résultats
C
      jg=nroot
      segini mlreel
      DO 52 I=1,NROOT
        prog(i)=Q(I)
   52 CONTINUE
  100 continue
      segact mlreel*mod
      mlree1=mlreei
      if(ireel.eq.0) segact mlree1*mod
*       write(6,*) 'avant ',( prog(io),io=1,prog(/1))
* on commence par ordonnée en ordre croissant
  101   continue
        ienc=0
*         write(6,*) ' prog(/1)' , prog(/1)
        do 102 i=1,prog(/1)-1
*         write(6,*)  ' i ' ,i
          if( prog(i) . gt. prog (i+1) ) then
            a= prog(i)
            prog(i)= prog(i+1)
            prog(i+1)=a
            if(ireel.eq.0) then
             a = mlree1.prog(i)
             mlree1.prog(i)=mlree1.prog(i+1)
             mlree1.prog(i+1)=a
            endif
            ienc=1
         endif
  102   continue
        if(ienc.eq.1) go to 101
*       write(6,*) 'apres ',( prog(io),io=1,prog(/1))
       if(ireel.eq.0) then
          call ecrobj ('LISTREEL',mlree1)
          segdes mlree1
      endif
      call ecrobj ('LISTREEL' , mlreel)
      segdes mlreel
      RETURN
      END
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 

© Cast3M 2003 - Tous droits réservés.
Mentions légales