Télécharger la plaquette Cast3M


fr en

Télécharger procpn.eso

Retour à la liste

Numérotation des lignes : 

procpn

  1. C PROCPN    SOURCE    PV090527  23/01/05    21:15:04     11542          
  2.       SUBROUTINE PROCPN(IAREA,IRET)
  3.       IMPLICIT INTEGER(I-N)
  4.  
  5. -INC PPARAM
  6. -INC CCOPTIO
  7. -INC CCNOYAU
  8. -INC CQALITE
  9.       SAVE SPROCEDUR
  10.       SAVE nbproc,iargu_sauv
  11.       SEGMENT SPROCEDUR
  12. *  nomcom nom du fichier de la procedure
  13. *  nomcou nom de la de la procedure
  14.        CHARACTER*(LOCHAI) nomcom(procdim)
  15.        CHARACTER*(LONOM)  nomcou(procdim)
  16.       ENDSEGMENT
  17.  
  18.       integer procdim
  19.       external long
  20.       CHARACTER*(*) IAREA
  21.       character*(lochai) rep,entr,cvarenv,dirb
  22.       character*(LONOM) nomf,nomm
  23.       character*(*) noml
  24.       equivalence(cvarenv,ivarenv)
  25.       equivalence(entr   ,ientr  )
  26. *  initialistion segment procedures
  27.       procdim=1000
  28.       segini sprocedur
  29. * recherche et ouverture des repertoires
  30.       cvarenv='CASTEM_PROCEDUR' //char(0)
  31.       l=lochai
  32.       call ooozen(ivarenv,l)
  33.       if (l.gt.1) then
  34.         rep=cvarenv(1:l)
  35.       else
  36.         rep='./:./procedur/:/u2/castem/procedur/'
  37.       endif
  38.       l=long(rep)
  39. **    write(6,*) 'rep: ',l,rep
  40.       idrep=1
  41.       ifrep=l
  42.       nbproc=0
  43. *  boucle sur les repertoires indiques
  44.   20  continue
  45. *  recherche debut fin du repertoire
  46. %IF WIN32,WIN64
  47.       ind=index(rep(idrep:ifrep),';')
  48. %ELSE
  49.       ind=index(rep(idrep:ifrep),':')
  50. %ENDIF
  51. **    ind=index(rep(idrep:ifrep),';')
  52. **    if (ind.eq.0) ind=index(rep(idrep:ifrep),':')
  53.       if(ind.eq.0)  ind=ifrep-idrep+2
  54.       ifrep=ind+idrep-2
  55.       dirb=rep(idrep:ifrep)
  56.       lgb=long(dirb)
  57. *     write(6,*)' ouverture de:',dirb(1:lgb),lgb
  58. %IF WIN32,WIN64
  59.       if(dirb(lgb:lgb).ne.'/'.and.dirb(lgb:lgb).ne.'\') then
  60. %ELSE
  61.       if(dirb(lgb:lgb).ne.'/') then
  62. %ENDIF
  63. **        write(6,*) 'ajout de / '
  64.         dirb(1:lgb+1)=dirb(1:lgb)//'/'
  65.         lgb=lgb+1
  66.       endif
  67.       call fopendir(dirb(1:lgb)//char(0),iret,iajout)
  68. **    write(6,*) ' ouverture repertire ',dirb(1:lgb)
  69.       if (iret.ne.0) then
  70.          lgbt=min(lgb,128)
  71.         moterr        =dirb(1:lgbt)
  72.        if(dirb(1:lgbt).ne.'./procedur/') call erreur(1133)
  73.       else
  74. *  lecture du contenu
  75.   10  continue
  76.       entr=char(0)
  77.       call freaddir(ientr)
  78.       if(ichar(entr(1:1)).ne.0) then
  79.        lg=long(entr)-1
  80. **     write(6,*) 'entr',lg,entr(1:50)
  81.        ind=index(entr(max(1,lg-8):lg),'.procedur')
  82.        if(ind.ne.0) then
  83.         ind=ind+lg-9
  84.         nomf=entr(1:ind-1)
  85. **      write(6,*) 'fichier procedur trouve:', nomf
  86.         call chcass(nomf,1,nomm)
  87. **      write(6,*) ' nom de la procedur ',nomf
  88.         do j=1,nbproc
  89.          if (nomcou(j).eq.nomm) then
  90.           moterr     =nomm
  91.           call erreur(-302)
  92.           iqpro=1
  93.           goto 10
  94.          endif
  95.         enddo
  96.         nbproc=nbproc+1
  97.         if(nbproc.gt.procdim) then
  98.            procdim=procdim+1000
  99.            segadj sprocedur
  100.         endif
  101.         call nomobj('PROCEDUR',nomm,-nbproc)
  102.         nomcou(nbproc)=nomm
  103. **      write(6,*) 'nomf(1:ind-1)',nomf(1:ind-1)
  104.         nomcom(nbproc)(1:lgb+ind-1+10)=
  105.      >    dirb(1:lgb)//nomf(1:ind-1)//'.procedur'//char(0)
  106. **      write(6,*) nomcou(nbproc),' ',nomcom(nbproc)
  107.        endif
  108.        goto 10
  109.       endif
  110.       call fclosedir
  111.       endif
  112. *  il faut sauter le separateur
  113.       idrep=ifrep+2
  114.       ifrep=l
  115.       if (idrep.lt.l) goto 20
  116.       procdim=nbproc
  117.       segadj sprocedur
  118.       return
  119. *  lecture procedur
  120.       entry procli(iarea,iret)
  121. **     write(6,*) 'iret en entree',iret
  122. ***    iargu=iargu_sauv
  123.        read (36,fmt='(A500)',end=1000) iarea
  124.        iret=iret+1
  125.        if(iarea(1:4).eq.'$$$$')
  126.      > read (36,fmt='(A500)',end=1000) iarea
  127.       return
  128.  1000 continue
  129.       iret=99999
  130.       return
  131. conversion nom numero
  132.       entry procl2(noml,iret)
  133.       do i=1,nbproc
  134.        if(nomcou(i).eq.noml) then
  135.           iret=i
  136.           return
  137.        endif
  138.       enddo
  139.       iret=0
  140.       return
  141. *  procedure en lecture
  142.       entry procl1(noml)
  143.       noml=nomcou(iargu_sauv)
  144.       return
  145. *  ouverture procedure
  146.       entry procpo(iargu,iret)
  147.        iargu_sauv=iargu
  148. **     write(6,*) 'procpo iargu ',iargu
  149.        close(unit=36)
  150.        segact sprocedur
  151.        if (iargu.gt.nbproc) call erreur(5)
  152.        if (iargu.le.0) call erreur(5)
  153.        iargu_sauv=iargu
  154. **     write(6,*) ' ouverture de ',nomcom(iargu)
  155.        open(file=nomcom(iargu),unit=36,iostat=ios)
  156. **     write(6,*) 'ios= ',ios
  157.        if (ios.ne.0) call erreur(5)
  158.        iret=99999
  159.        return
  160.       end
  161.  
  162.  
  163.  
  164.  
  165.  

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