Sources Esope | Cast3M

nouins2
C NOUINS2   SOURCE    PV090527  24/01/09    21:15:19     11817          
C  nouins version esclave
C
      SUBROUTINE NOUINS2
      IMPLICIT INTEGER(I-N)
 
-INC PPARAM
-INC CCASSIS
-INC CCOPTIO
-INC CCNOYAU
-INC SMCOORD
-INC SMLMOTS
-INC SMBLOC
 
      logical ilog , LLLERR
      real*8 reel
      character*(LOCHAI) chaine
      character*8 ityp
*
      call ooonsf(0)
*
*  initialisation de lotesc
      ith=0
      ith=oothrd
      call ooohor(0)
*     write (6,*) ' dans nouins2  ',ith
      if ((ith.eq.0) .and. lotrma) then
        call erreur(5)
* le maitre travaille comme un assistant
        mesins = mescl(ith)
        mestra = imestr
        lotrma = .false.
        lotesc = .true.
        goto 3457
      end if
*
      mescla = imescl(ith)
      mestra = imestr
      mesins = mescl(ith)
*     est on en situation d'erreur????
      merres = ierres
      segact merres
      LLLERR = LOSIER
      segdes merres
*  mettre les resultats dans la pile de l'esclave
      IIRES = 0
      do 10 iop=1,90
        call quetyp(ityp,0,iretou)
        if (iretou.eq.0) goto 11
        IIRES = IIRES + 1
        mesres=esrees(iop)
        if (mesres.eq.0) then
          moterr(1:8) = ityp
          moterr(9:16) = '        '
          call erreur(11)
          goto 11
        end if
* Il faut activer mesres avant nesres pour eviter des problemes
* d'interferences et de validiter de LOREMP
        if (iimpi .eq. 1234) write(ioimp,*) 'mise a jour de',mesres
        segact mesres*mod
        LOREMP = .TRUE.
        esrety=ityp
        if (ityp.eq.'LOGIQUE ') then
          call lirlog(ilog,1,iretou)
          esrelo=ilog
        elseif(ityp.eq.'FLOTTANT') then
          call lirree(reel,1,iretou)
          esrere=reel
        elseif (ityp.eq.'MOT     ') then
          call lircha(chaine,1,iretou)
          esrech=chaine
        else
          call lirobj(ityp,iob,1,iretou)
          esreva=iob
        endif
****** CJY
        if (ith.ne.0) then
          segdes mesres*record
        else
          segdes mesres
        endif
  10  continue
  11  continue
*     en situation d'erreur on genere des objets de type ANNULE
      IF ( LLLERR ) IIRES = 0
C -
C -   il faut verifier si il ne reste pas d'objets ESCLAVE dans la pile
      DO II = IIRES+1 , 90
        MESRES = esrees(II)
        IF ( MESRES .EQ. 0 ) THEN
          GO TO 4321
        ELSE
          SEGACT MESRES*MOD
          LOREMP = .TRUE.
          ESRETY = 'ANNULE  '
 
C         Gestion du SOUCI dans le BLOC (COMMENTE ACTUELLEMENT)
C         ESISOU = MBSOUC
 
          if (ith.ne.0) then
             SEGDES MESRES*RECORD
          else
             SEGDES MESRES
          endif
        END IF
      END DO
4321  CONTINUE
* Y a t il eu une erreur ?
      MLMOT1 = jpcar1
      IF ( JJJERR .NE. 0 .OR. LLLERR ) THEN
C JYYY        segact mesins
        merres = ierres
        segact merres*mod
        NERR = liserr(/2)
        IF ( NBERR .eq. NERR) then
          NERR = NERR + 2
          segadj merres
        END IF
        NBERR = NBERR + 1
        LISERR(1,NBERR) = JJJERR
        LISERR(2,NBERR) = MLMOT1
        LISERR(3,NBERR) = ith
        segdes mlmot1
C JYYY        segdes mesins*record
        segdes merres
      ELSE
        SEGSUP MLMOT1
      END IF
** plus utile menage travaille correctement sur les mescla
***   CALL LIBSEG ( mescla )
      SEGSUP mescla
      segdes mcoord
* recherche d une nouvelle instruction
      segact mesins*mod
      INSCOU = 0
3456  CONTINUE
 
*      write (6,*) ' ith nbins dans nouins2 ',ith,nbins
      IF ( NBINS .EQ. 0 ) THEN
          if (inass .eq. 0) then
*           write(6,*) 'nouins2, on ne doit pas passer la '
            lotesc = .false.
*     write (6,*) ' desactivation mesins ith ',mesins,ith
            segdes mestra
            segdes mesins*record
            return
          else
            if (iospi .ne. 0)
     &          write(ioimp,*) ' il faut attendre une instruction'
            SEGDES MESINS*RECORD
*     write (6,*) ' activation mesins ith ',mesins,ith
            segdes mestra
            SEGACT MESINS*(MOD,ECR=1)
            segact mestra
* menage a peut-etre desactive mesins le temps que mestra soit accessible
            SEGACT MESINS*(MOD,ECR=1)
            GOTO 3456
          endif
      END IF
*------------
3457    continue
*       est on en situation d'erreur????
        merres = ierres
        segact merres
        LLLERR = LOSIER
        segdes merres
**        print*, ' il y a du travail a faire, NBINS =', NBINS
        mescla = LISMES(1)
        imescl(ith) = mescla
        INSCOU = MESCLA
        NBINS = NBINS - 1
        IF ( NBINS .NE. 0 ) THEN
          do i = 1 , NBINS
            lismes(i) = lismes(i+1)
          end do
        END IF
 
*       en erreur on vide la queue d'instrutions
C       On positionne JERR au MAXI entre l'erreur par ASSISTANT et l'erreur GLOBALE
        jerr=MAX(IERR,IERGLB)
        if(jerr .ne. 0) then
         nbins =0
         ierr  =0
         IERGLB=0
        endif
        lismes (NBINS+1) = 0
        SEGDES MESINS*RECORD
**      segact mescla*(mod)
**      ierr=0
        segdes mescla
*****   segact mestra
        segact mescla*(mod)
      call ooonsf(1)
 
      end