C PROCPN    SOURCE    PV090527  23/01/05    21:15:04     11542          
      SUBROUTINE PROCPN(IAREA,IRET)
      IMPLICIT INTEGER(I-N)

-INC PPARAM
-INC CCOPTIO
-INC CCNOYAU
-INC CQALITE
      SAVE SPROCEDUR
      SAVE nbproc,iargu_sauv
      SEGMENT SPROCEDUR
*  nomcom nom du fichier de la procedure
*  nomcou nom de la de la procedure
       CHARACTER*(LOCHAI) nomcom(procdim)
       CHARACTER*(LONOM)  nomcou(procdim)
      ENDSEGMENT

      integer procdim
      external long
      CHARACTER*(*) IAREA
      character*(lochai) rep,entr,cvarenv,dirb
      character*(LONOM) nomf,nomm
      character*(*) noml
      equivalence(cvarenv,ivarenv)
      equivalence(entr   ,ientr  )
*  initialistion segment procedures
      procdim=1000
      segini sprocedur
* recherche et ouverture des repertoires
      cvarenv='CASTEM_PROCEDUR' //char(0)
      l=lochai
      call ooozen(ivarenv,l)
      if (l.gt.1) then
        rep=cvarenv(1:l)
      else
        rep='./:./procedur/:/u2/castem/procedur/'
      endif
      l=long(rep)
**    write(6,*) 'rep: ',l,rep
      idrep=1
      ifrep=l
      nbproc=0
*  boucle sur les repertoires indiques
  20  continue
*  recherche debut fin du repertoire
%IF WIN32,WIN64
      ind=index(rep(idrep:ifrep),';')
%ELSE
      ind=index(rep(idrep:ifrep),':')
%ENDIF
**    ind=index(rep(idrep:ifrep),';')
**    if (ind.eq.0) ind=index(rep(idrep:ifrep),':')
      if(ind.eq.0)  ind=ifrep-idrep+2
      ifrep=ind+idrep-2
      dirb=rep(idrep:ifrep)
      lgb=long(dirb)
*     write(6,*)' ouverture de:',dirb(1:lgb),lgb
%IF WIN32,WIN64
      if(dirb(lgb:lgb).ne.'/'.and.dirb(lgb:lgb).ne.'\') then
%ELSE
      if(dirb(lgb:lgb).ne.'/') then
%ENDIF
**        write(6,*) 'ajout de / '
        dirb(1:lgb+1)=dirb(1:lgb)//'/'
        lgb=lgb+1
      endif
      call fopendir(dirb(1:lgb)//char(0),iret,iajout)
**    write(6,*) ' ouverture repertire ',dirb(1:lgb)
      if (iret.ne.0) then
         lgbt=min(lgb,128)
        moterr        =dirb(1:lgbt)
       if(dirb(1:lgbt).ne.'./procedur/') call erreur(1133)
      else
*  lecture du contenu
  10  continue
      entr=char(0)
      call freaddir(ientr)
      if(ichar(entr(1:1)).ne.0) then
       lg=long(entr)-1
**     write(6,*) 'entr',lg,entr(1:50)
       ind=index(entr(max(1,lg-8):lg),'.procedur')
       if(ind.ne.0) then
        ind=ind+lg-9
        nomf=entr(1:ind-1)
**      write(6,*) 'fichier procedur trouve:', nomf
        call chcass(nomf,1,nomm)
**      write(6,*) ' nom de la procedur ',nomf
        do j=1,nbproc
         if (nomcou(j).eq.nomm) then
          moterr     =nomm
          call erreur(-302)
          iqpro=1
          goto 10
         endif
        enddo
        nbproc=nbproc+1
        if(nbproc.gt.procdim) then
           procdim=procdim+1000
           segadj sprocedur
        endif
        call nomobj('PROCEDUR',nomm,-nbproc)
        nomcou(nbproc)=nomm
**      write(6,*) 'nomf(1:ind-1)',nomf(1:ind-1)
        nomcom(nbproc)(1:lgb+ind-1+10)=
     >    dirb(1:lgb)//nomf(1:ind-1)//'.procedur'//char(0)
**      write(6,*) nomcou(nbproc),' ',nomcom(nbproc)
       endif
       goto 10
      endif
      call fclosedir
      endif
*  il faut sauter le separateur
      idrep=ifrep+2
      ifrep=l
      if (idrep.lt.l) goto 20
      procdim=nbproc
      segadj sprocedur
      return
*  lecture procedur
      entry procli(iarea,iret)
**     write(6,*) 'iret en entree',iret
***    iargu=iargu_sauv
       read (36,fmt='(A500)',end=1000) iarea
       iret=iret+1
       if(iarea(1:4).eq.'$$$$')
     > read (36,fmt='(A500)',end=1000) iarea
      return
 1000 continue
      iret=99999
      return
conversion nom numero
      entry procl2(noml,iret)
      do i=1,nbproc
       if(nomcou(i).eq.noml) then
          iret=i
          return
       endif
      enddo
      iret=0
      return
*  procedure en lecture
      entry procl1(noml)
      noml=nomcou(iargu_sauv)
      return
*  ouverture procedure
      entry procpo(iargu,iret)
       iargu_sauv=iargu
**     write(6,*) 'procpo iargu ',iargu
       close(unit=36)
       segact sprocedur
       if (iargu.gt.nbproc) call erreur(5)
       if (iargu.le.0) call erreur(5)
       iargu_sauv=iargu
**     write(6,*) ' ouverture de ',nomcom(iargu)
       open(file=nomcom(iargu),unit=36,iostat=ios)
**     write(6,*) 'ios= ',ios
       if (ios.ne.0) call erreur(5)
       iret=99999
       return
      end