Télécharger la plaquette Cast3M


fr en

Télécharger lextpn.eso

Retour à la liste

Numérotation des lignes : 

lextpn

  1. C LEXTPN    SOURCE    OF166741  25/04/11    21:15:02     12233          
  2.  
  3. *----------------------------------------------------------------------*
  4.       SUBROUTINE LEXTPN (iret)
  5.  
  6.       IMPLICIT INTEGER(I-N)
  7.       IMPLICIT REAL*8(A-H,O-Z)
  8.  
  9. -INC PPARAM
  10. -INC CCOPTIO
  11.  
  12.       PARAMETER (LOCHAV = 60 * LOCHAI)
  13.       PARAMETER (LOCHAJ = 10 * LOCHAI)
  14.       PARAMETER (NBLIB  = 3)
  15.  
  16. *  dirloi repertoire de la loi externe
  17.       SEGMENT SDIEXT
  18.         INTEGER            ndiext = 0
  19.         CHARACTER*(LOCHAI) dirloi(nbdir)
  20.       ENDSEGMENT
  21.  
  22. *  ficloi fichier (bibliotheque) de la loi externe
  23. *  idrloi entier correspondant a dirloi de SDIEXT
  24.       SEGMENT SLOEXT
  25.         INTEGER            nloext = 0
  26.         CHARACTER*(LOCHAI) ficloi(nbloi)
  27.         INTEGER            idrloi(nbloi)
  28.       ENDSEGMENT
  29.  
  30. *DEV*  nomloi nom de la loi externe dans la bibliotheque
  31. *DEV*  idfloi entier correspondant a ficloi de SLOEXT
  32. *DEV*  iptloi pointeur fonction de la loi externe
  33. *DEV      SEGMENT SFCEXT
  34. *DEV        INTEGER            nfcext = 0
  35. *DEV        CHARACTER*(LOCHAI) nomloi(nbfct)
  36. *DEV        INTEGER            idfloi(nbfct)
  37. *DEV        INTEGER            iptloi(nbfct)
  38. *DEV      ENDSEGMENT
  39.  
  40.       EXTERNAL long
  41.  
  42.       CHARACTER*(*) repl,ficl,noml
  43.  
  44.       CHARACTER*(LOCHAV) cvarenv,rep,entr
  45.       CHARACTER*(LOCHAI) dirb,ficb,nomb
  46.       CHARACTER*(1)      sepa1(NBLIB)
  47.       CHARACTER*(2)      sepa2(NBLIB)
  48.       CHARACTER*(6)      sextl(NBLIB)
  49.       INTEGER            lextl(NBLIB)
  50.  
  51.       EQUIVALENCE(cvarenv,ivarenv)
  52.       EQUIVALENCE(entr   ,ientr  )
  53.  
  54.       LOGICAL logdbg, b_z
  55.  
  56.       SAVE SDIEXT, SLOEXT
  57. *DEV      SAVE SFCEXT
  58.       SAVE sepa1, sepa2, sextl, lextl, iextl
  59.       SAVE logdbg
  60.  
  61. * Option cachee de debogage :
  62.       cvarenv = 'CASTEM_MFRONT_DEBUG'//CHAR(0)
  63.       l = LOCHAJ
  64.       CALL OOOZEN(ivarenv,l)
  65.       logdbg = l.GE.1
  66.       if (logdbg) write(ioimp,*) 'Mode debogage actif'
  67.  
  68.       iret = 0
  69. * 0 - Initialisation des segments sdiext, sloext, sfcext
  70.       nbdir = 32
  71.       SEGINI,sdiext
  72.  
  73.       nbloi = 128
  74.       SEGINI,sloext
  75.  
  76. *DEV      nbfct = 128
  77. *DEV      SEGINI,sfcext
  78.  
  79. * 1 - Definition pour chaque OS (LINUX, WIN, MAC) :
  80. *         - du separateur de recherche
  81. *         - du(des) separateur(s) de repertoire
  82. *         - de l'extension de la bibliotheque
  83.       sextl(1) = '.so   '
  84.       lextl(1) = 3
  85.       sepa1(1) = ':'
  86.       sepa2(1) = '//'
  87.       sextl(2) = '.dll  '
  88.       lextl(2) = 4
  89.       sepa1(2) = ';'
  90.       sepa2(2) = '\/'
  91.       sextl(3) = '.dylib'
  92.       lextl(3) = 6
  93.       sepa1(3) = ':'
  94.       sepa2(3) = '//'
  95. %IF WIN32,WIN64
  96.       iextl = 2
  97. %ELSE
  98.       iextl = 1
  99. * Cas particulier du MACOS
  100.       cvarenv = 'CASTEM_PLATEFORME'//CHAR(0)
  101.       l = LOCHAI
  102.       CALL OOOZEN(ivarenv,l)
  103.       IF (l.GE.1) THEN
  104.         IF (cvarenv(1:l).EQ.'MAC') iextl = 3
  105.       END IF
  106. %ENDIF
  107.       if (logdbg) then
  108.         if (iextl.eq.1) write(ioimp,*) 'OS = LINUX (default)'
  109.         if (iextl.eq.2) write(ioimp,*) 'OS = WIN32/WIN64'
  110.         if (iextl.eq.3) write(ioimp,*) 'OS = MACOS64'
  111.       end if
  112.  
  113. * 2 - Recherche des repertoires a scruter
  114.       rep   = '.'//sepa1(iextl)(1:1)//'.'//sepa2(iextl)(1:1)//'src'
  115.       lgrep = LONG(rep)
  116.       cvarenv = 'CASTEM_MFRONT_PATH'//CHAR(0)
  117.       l = LOCHAV
  118.       CALL OOOZEN(ivarenv,l)
  119.       IF (l.GE.1) THEN
  120.         if (lgrep+1+l.gt.LOCHAV) then
  121.           moterr = '(Warning 0) CASTEM_MFRONT_PATH too long'
  122.           call erreur(-385)
  123.           moterr = '=> Variable not used'
  124.           call erreur(-385)
  125.           iret = iret + 1
  126.         else
  127.       if (logdbg) write(ioimp,*) 'rep =>CASTEM_MFRONT_PATH<='
  128.           lgrep = lgrep + 1
  129.           rep(lgrep:lgrep) = sepa1(iextl)(1:1)
  130.           rep(lgrep+1:lgrep+l) = cvarenv(1:l)
  131.           GOTO 2
  132.         end if
  133.       END IF
  134.       cvarenv = 'LD_LIBRARY_PATH'//CHAR(0)
  135.       if (iextl.eq.3) cvarenv = 'DYLD_LIBRARY_PATH'//CHAR(0)
  136.       l = LOCHAV
  137.       CALL OOOZEN(ivarenv,l)
  138.       IF (l.GE.1) THEN
  139.         if (lgrep+1+l.gt.LOCHAV) then
  140.           moterr = '(Warning 0) (DY)LD_LIBRARY_PATH too long'
  141.           call erreur(-385)
  142.           moterr = '=> Variable not used'
  143.           call erreur(-385)
  144.           iret = iret + 1
  145.         else
  146.       if (logdbg) write(ioimp,*) 'rep =>(DY)LD_LIBRARY_PATH<='
  147.           lgrep = lgrep + 1
  148.           rep(lgrep:lgrep) = sepa1(iextl)(1:1)
  149.           rep(lgrep+1:lgrep+l) = cvarenv(1:l)
  150.           GOTO 2
  151.         end if
  152.       END IF
  153.       if (logdbg) write(ioimp,*) 'rep =>default<='
  154.  2    CONTINUE
  155.       lgrep = LONG(rep)
  156.       if (logdbg) write(ioimp,*) 'rep "',rep(1:lgrep),'"',lgrep
  157.  
  158.       idrep  = 1
  159. * 3 - Boucle sur les repertoires indiques
  160.  30   CONTINUE
  161.  
  162. * 3.1 - Analyse du nom du repertoire
  163.         ifrep = lgrep
  164. *  Recherche debut fin du repertoire
  165.         ind = INDEX(rep(idrep:ifrep),sepa1(iextl)(1:1))
  166.         IF (ind.NE.0) ifrep = idrep + ind - 2
  167. *  Cas particulier ou 2 separateurs se suivent
  168.         IF (ind.EQ.1) GOTO 31
  169.         lgd = LONG(rep(idrep:ifrep))
  170. *  Cas particulier ou il n'y a que des espaces entre 2 separateurs
  171.         IF (lgd.EQ.0) GOTO 31
  172.  
  173.         CALL LEXTDA(rep(idrep:ifrep),ios,inew)
  174.         IF (ios.LE.0 .OR. inew.EQ.0) GOTO 31
  175.  
  176.         idiext = ios
  177. * 3.2 - Analyse des bibliotheques contenues dans le "nouveau" repertoire
  178.         CALL LEXTDC(idiext,ios)
  179. c*        IF (ios.LT.0) GOTO 31
  180.  
  181. * Il faut sauter le separateur
  182.  31     CONTINUE
  183.         idrep = ifrep + 2
  184. * Fin de la chaine rep atteinte ?
  185.         IF (idrep.GE.lgrep) GOTO 4
  186.       GOTO 30
  187. * 3 - Fin de la boucle sur les repertoires
  188.  
  189. * 4 - Fin du traitement initial des repertoires de bibliotheques de loi
  190.  4    CONTINUE
  191.       if ( (ndiext.eq.0 .and. nloext.ne.0) .or.
  192.      &     (ndiext.ne.0 .and. nloext.eq.0) ) then
  193.         moterr = '(Fatal Error) External laws: '//
  194.      &           'ndiext & nloext not consistent'
  195.         call erreur(-385)
  196.         call erreur(5)
  197.       end if
  198.  
  199.       SEGACT,sdiext*MOD
  200.       nbdir = sdiext.ndiext
  201.       SEGADJ,sdiext
  202.       SEGACT,sdiext*NOMOD
  203. *DEV      CALL SAVSEG(sdiext)
  204.  
  205.       SEGACT,sloext*MOD
  206.       nbloi = sloext.nloext
  207.       SEGADJ,sloext
  208.       SEGACT,sloext*NOMOD
  209. *DEV      CALL SAVSEG(sloext)
  210.  
  211. *DEV      SEGACT,sfcext*MOD
  212. *DEV      nbfct = sfcext.nfcext
  213. *DEV      SEGADJ,sfcext
  214. *DEV      SEGACT,sfcext*NOMOD
  215. *DEV      CALL SAVSEG(sdiext)
  216.  
  217.       if (logdbg) CALL LEXTPR(0)
  218.  
  219.       RETURN
  220.  
  221. *-1--------------------------------------------------------------------*
  222. *  Conversion repertoire numero :
  223. *  (E) repl : nom/chemin complet du repertoire a analyser
  224. *  (S) iret : > 0 correspond au numero du repertoire dans la liste
  225. *             = 0 si non trouve
  226. *             < 0 cas particuliers (erreurs potentielles)
  227. *----------------------------------------------------------------------*
  228.       ENTRY LEXTDN(repl,iret)
  229.  
  230.       lgd = LONG(repl)
  231. c*dbg      if (logdbg) write(ioimp,*) 'LEXTDN ='//repl(1:lgd)//'=',lgd
  232.       iret = -2
  233.       if (lgd.LE.0 .OR. lgd.GT.LOCHAI) RETURN
  234.  
  235.       iret = 0
  236. **      SEGACT,sdiext*NOMOD
  237.       DO i = 1, sdiext.ndiext
  238.         l_z = LONG(sdiext.dirloi(i))
  239.         IF (l_z .EQ. lgd) THEN
  240.           IF (sdiext.dirloi(i)(1:lgd).EQ.repl(1:lgd)) THEN
  241.             iret = i
  242. c*dbg      if (logdbg) write(ioimp,*) 'LEXTDN = repl trouve en',iret
  243.             RETURN
  244.           END IF
  245.         END IF
  246.       END DO
  247. c*dbg      if (logdbg) write(ioimp,*) 'LEXTDN = repl non trouve',iret
  248.       RETURN
  249.  
  250. *-2--------------------------------------------------------------------*
  251. *  Conversion bibliotheque/fichier numero :
  252. *  (E) idirep : numero du repertoire auquel appartient la bibliotheque
  253. *               si =0 ou <0, verification que le nom de la bibliotheque
  254. *               est dans la liste sans controler le repertoire
  255. *  (E) ficl : nom de la bibliotheque a analyser
  256. *  (S) iret : > 0 correspond au numero de la bibliotheque dans la liste
  257. *             = 0 si non trouvee
  258. *             < 0 cas particuliers (erreurs potentielles)
  259. *----------------------------------------------------------------------*
  260.       ENTRY LEXTFN(idirep,ficl,iret)
  261.  
  262.       iret = -1
  263.       if (idirep.gt.sdiext.ndiext) RETURN
  264.  
  265.       lgf = LONG(ficl)
  266. c*dbg      if (logdbg) write(ioimp,*) 'LEXTFN ='//ficl(1:lgf)//'=',lgf,idirep
  267.       iret = -2
  268.       if (lgf.LE.0 .OR. lgf.GT.LOCHAI) RETURN
  269.  
  270.       iret = 0
  271. **      SEGACT,sloext*NOMOD
  272.       DO i = 1, nloext
  273.         l_z = LONG(sloext.ficloi(i))
  274.         IF (l_z.EQ.lgf) THEN
  275.           IF (sloext.ficloi(i)(1:lgf).EQ.ficl(1:lgf)) THEN
  276.             IF (idirep.LE.0) THEN
  277.               iret = i
  278. c*dbg      if (logdbg) write(ioimp,*) 'LEXTFN(1) = ficl trouve en',i
  279.               RETURN
  280.             ELSE
  281.               IF (sloext.idrloi(i).EQ.idirep) THEN
  282.                 iret = i
  283. c*dbg      if (logdbg) write(ioimp,*) 'LEXTFN(2) = ficl trouve en',i
  284.                 RETURN
  285.               END IF
  286.             END IF
  287.           END IF
  288.         END IF
  289.       END DO
  290. c*dbg      if (logdbg) write(ioimp,*) 'LEXTFN(0) = ficl non trouve',iret
  291.       RETURN
  292.  
  293. *-3--------------------------------------------------------------------*
  294. *  Conversion fonction(nom) numero
  295. *  (E) noml : nom de la fonction a analyser
  296. *  (S) iret : > 0 correspond au numero de la fonction dans la liste
  297. *             = 0 si non trouvee
  298. *             < 0 cas particuliers (erreurs potentielles)
  299. *----------------------------------------------------------------------*
  300.       ENTRY LEXTNN(noml,iret)
  301.  
  302.       iret = -2
  303.       lgn = LONG(noml)
  304.       if (lgn.LE.0 .OR. lgn.GT.LOCHAI) RETURN
  305.       iret = 0
  306. *dbg      write(ioimp,*) 'LEXTNN ='//noml(1:lgn)//'='
  307. *DEV***      SEGACT,sfcext*NOMOD
  308. *DEV*      DO i = 1, nfcext
  309. *DEV*        l_z = LONG(sfcext.nomloi(i))
  310. *DEV*        IF (l_z.EQ.lgn) THEN
  311. *DEV*          IF (sfcext.nomloi(i)(1:lgn).EQ.noml(1:lgn)) THEN
  312. *DEV*            iret = i
  313. *DEV*            RETURN
  314. *DEV*          END IF
  315. *DEV*        END IF
  316. *DEV*      END DO
  317.       RETURN
  318.  
  319. *-4--------------------------------------------------------------------*
  320. *  Analyse et ajout d'un repertoire a la liste :
  321. *  (E) repl : nom/chemin complet du repertoire a analyser
  322. *  (S) iret : > 0 correspond au numero du repertoire dans la liste
  323. *             < 0 en cas de souci (nom trop long...)
  324. *             = 0 repertoire non traite (nom du repertoire = "")
  325. *  (S) inov : = 1 si le repertoire est nouveau et a ete ajoute,
  326. *             = 0 sinon (repertoire deja liste)
  327. *  (E/S) segment sdiext modifie selon
  328. *----------------------------------------------------------------------*
  329.       ENTRY LEXTDA(repl,iret,inov)
  330.  
  331.       inov = 0
  332.       lgd = LONG(repl)
  333. c*dbg      if (logdbg) write(ioimp,*) 'LEXTDA ='//repl(1:lgd)//'=',lgd
  334.       iret = 0
  335.       if (lgd.le.0) goto 420
  336.       iret = -1
  337.       if (lgd.gt.LOCHAI) goto 410
  338.       dirb = ' '
  339.       dirb = repl(1:lgd)
  340. *  Cas particulier du melange de "separateurs de repertoire" (sepa2)
  341.       DO i = 1, lgd
  342.         IF (dirb(i:i).EQ.sepa2(iextl)(2:2)) THEN
  343.           dirb(i:i) = sepa2(iextl)(1:1)
  344.         END IF
  345.       END DO
  346. *  Ajout du separateur en fin de repertoire s'il manque
  347.       IF (dirb(lgd:lgd).NE.sepa2(iextl)(1:1)) THEN
  348.         if (lgd.ge.LOCHAI) then
  349.           iret = -2
  350.           goto 410
  351.         end if
  352.         lgd = lgd + 1
  353.         dirb(lgd:lgd) = sepa2(iextl)(1:1)
  354.       END IF
  355. *  Recherche du numero associe au repertoire s'il existe deja
  356.       CALL LEXTDN(dirb,ios)
  357.       IF (ios.GT.0) THEN
  358.         iret = ios
  359.         RETURN
  360.       END IF
  361. * On ajoute le repertoire a la liste :
  362.       SEGACT,sdiext*MOD
  363.       sdiext.ndiext = sdiext.ndiext + 1
  364.       ios   = sdiext.ndiext
  365.       nbdir = sdiext.dirloi(/2)
  366.       IF (ios.GT.nbdir) THEN
  367.         nbdir = nbdir + 32
  368.         SEGADJ,sdiext
  369.       END IF
  370.       sdiext.dirloi(ios) = ' '
  371.       sdiext.dirloi(ios)(1:lgd) = dirb(1:lgd)
  372.       SEGACT,sdiext*NOMOD
  373.       if (logdbg) then
  374.         moterr = '(Warning 4.0) External laws: Directory added'
  375.         call erreur(-385)
  376.         moterr = ' "'//dirb(1:lgd)//'"'
  377.         call erreur(-385)
  378.       end if
  379. * On retourne les arguments :
  380.       inov = 1
  381.       iret = ios
  382.       GOTO 400
  383.  
  384. * Traitement des erreurs :
  385.  410  CONTINUE
  386.       if (logdbg) then
  387.         moterr = '(Warning 4.1) External laws: Directory name too long'
  388.         call erreur(-385)
  389.         l = 60
  390.         moterr = ' "'//repl(1:1+l)//'[...]'//
  391.      &           repl(lgd-l-1:lgd)//sepa2(iextl)(1:1)//'"'
  392.         call erreur(-385)
  393. c*dbg        moterr = '=> Directory not used'
  394. c*dbg        call erreur(-385)
  395.       end if
  396.       GOTO 400
  397.  420  CONTINUE
  398.       if (logdbg) then
  399.         moterr = '(Warning 4.2) External laws: Directory name null size'
  400.         call erreur(-385)
  401.       end if
  402.       GOTO 400
  403.  
  404.  400  CONTINUE
  405.       RETURN
  406.  
  407. *-5--------------------------------------------------------------------*
  408. *  Ajout des bibliotheques (fichiers) contenues dans un repertoire
  409. *  (E) idirep : numero du repertoire dans la liste sdiext
  410. *  (S) iret   : = 0 si succes, < 0 souci (repertoire non retenu...)
  411. *  (E/S) segments sdiext et sloext modifies selon
  412. *----------------------------------------------------------------------*
  413.       ENTRY LEXTDC(idirep,iret)
  414.  
  415.       iret = -1
  416.       if (idirep.le.0) RETURN
  417.       if (idirep.gt.sdiext.ndiext) RETURN
  418.  
  419.       dirb = ' '
  420.       dirb = sdiext.dirloi(idirep)
  421.       lgd = LONG(dirb)
  422.  
  423. *- Ouverture du repertoire "complet"
  424.       ios = 0
  425.       CALL fopendir(dirb(1:lgd)//CHAR(0),ios,iajout)
  426.       IF (ios.NE.0) THEN
  427.         iret = -2
  428.         if (logdbg) then
  429.           moterr = '(Warning 5.1) External laws: Directory cannot '//
  430.      &             'be opened'
  431.           call erreur(-385)
  432.           if (lgd.gt.125) then
  433.             l = 60
  434.             moterr = ' "'//dirb(1:1+l)//'[...]'//dirb(lgd-l:lgd)//'"'
  435.           else
  436.             moterr = ' "'//dirb(1:lgd)//'"'
  437.           end if
  438.           call erreur(-385)
  439. c*dbg          moterr = '=> Directory not used'
  440. c*dbg          call erreur(-385)
  441.         end if
  442.         CALL LEXTDS(idirep,ios)
  443.         GOTO 500
  444.       END IF
  445.  
  446.       nlopre = sloext.nloext
  447. *- Boucle sur le contenu du repertoire
  448.  51   CONTINUE
  449.         entr = CHAR(0)
  450.         CALL freaddir(ientr)
  451.         IF (ICHAR(entr(1:1)).EQ.0) GOTO 52
  452. *- Analyse du fichier trouve :
  453.         lgf = LONG(entr) - 1
  454.         CALL LEXTFA(idirep,entr(1:lgf),.TRUE.,ios,inew)
  455.         IF (ios.LE.0 .OR. inew.EQ.0) GOTO 51
  456.  
  457. *DEV*- Analyse de la bibliotheque :
  458. *DEV*- Boucle sur le contenu de la bibiotheque
  459. *DEV 3110     CONTINUE
  460. *DEV*     on recupere la i-eme fonction dans la bibliotheque
  461. *DEV            nomb = ' '
  462. *DEV            lgn = LOCHAI
  463. *DEV            CALL LEXTNN(nomb,ios)
  464. *DEV            IF (ios.GT.0) then
  465. *DEV              moterr = nomb
  466. *DEV              CALL ERREUR(-302)
  467. *DEV              nloext = nloext - 1
  468. *DEV              goto 3110
  469. *DEV            END IF
  470. *DEV            nfcext = nfcext + 1
  471. *DEV            IF (nfcext.GT.nbfct) THEN
  472. *DEV              nbfct = nbfct + 128
  473. *DEV              SEGADJ,sfcext
  474. *DEV            END IF
  475. *DEV            sfcext.nomloi(nfcext) = ' '
  476. *DEV            sfcext.nomloi(nfcext)(1:lgn) = nomb(1:lgn)
  477. *DEV            sfcext.idfloi(nfcext) = nloext
  478. *DEV            sfcext.iptloi(nfcext) = 0
  479. *DEV          GOTO 3110
  480. *DEV* 3.3.3.3 - Fermeture de la bibiotheque
  481. *DEV 3120     CONTINUE
  482.  
  483.       GOTO 51
  484. *- Fin de la boucle sur le contenu du repertoire
  485.  52   CONTINUE
  486.       CALL fclosedir
  487.  
  488. * Si pas de bibliotheque dans le repertoire, on le retire :
  489.       IF (sloext.nloext .LE. nlopre) then
  490.         iret = -3
  491.         if (logdbg) then
  492.           moterr = '(Warning 5.2) External laws: '//
  493.      &             'No new librairies found in the directory'
  494.           call erreur(-385)
  495.         end if
  496.         CALL LEXTDS(idirep,ios)
  497.         GOTO 500
  498.       END IF
  499.  
  500.       iret = 0
  501.  
  502.  500  CONTINUE
  503.       RETURN
  504.  
  505. *-6--------------------------------------------------------------------*
  506. *  Analyse et ajout d'une bibliotheque (fichier) a la liste :
  507. *  (E) idirep : numero du repertoire auquel appartient la bibliotheque
  508. *               si =0 ou <0, verification que le nom de la bibliotheque
  509. *               est dans la liste sans controler le repertoire
  510. *  (E) ficl   : nom (avec ou sans extension) de la bibliotheque
  511. *  (E) b_z    : .TRUE. indique que l'extension doit etre obligatoirement 
  512. *               presente dans le nom du fichier et correspondre a l'OS.
  513. *  (S) iret : > 0 correspond au numero de la bibliothque dans la liste
  514. *             < 0 en cas de souci (nom trop long...)
  515. *             = 0 bibliotheque non trouvee ou non traitee car nom = ""
  516. *  (S) inov : = 1 si la bibliotheque est nouvelle et a ete ajoutee,
  517. *             = 0 sinon (bibliotheque deja listee)
  518. *  (E/S) segment sloext modifie selon
  519. *----------------------------------------------------------------------*
  520.       ENTRY LEXTFA(idirep,ficl,b_z,iret,inov)
  521.  
  522.       inov = 0
  523.       lgf = LONG(ficl)
  524. c*dbg      if (logdbg) write(ioimp,*) 'LEXTFA ='//ficl(1:lgf)//'=',lgf
  525.       iret = -1
  526.       if (lgf.le.0) goto 600
  527.       if (lgf.gt.LOCHAI) goto 610
  528.  
  529.       IF (b_z) THEN
  530.         ideb = iextl
  531.         ifin = iextl
  532.       ELSE
  533.         ideb = 1
  534.         ifin = NBLIB
  535.       ENDIF
  536.       nextl = 0
  537. * Recherche d'une extension si elle est fournie
  538.       DO i = ideb, ifin
  539.         j = lextl(i)
  540.         IF (lgf.GT.j) THEN
  541. %IF WIN32,WIN64
  542.           CALL CHCASS(ficl(lgf-j+1:lgf),0,ficb(1:j))
  543. %ELSE
  544.           ficb(1:j) = ficl(lgf-j+1:lgf)
  545. %ENDIF
  546.           IF (ficb(1:j).EQ.sextl(i)(1:j)) THEN
  547.             nextl = j
  548.             GOTO 601
  549.           END IF
  550.         END IF
  551.       END DO
  552.  601  CONTINUE
  553.       iret = -2
  554.       IF (b_z .AND. nextl.EQ.0) GOTO 620
  555.       lgf = lgf - nextl
  556.       ficb = ' '
  557.       ficb(1:lgf) = ficl(1:lgf)
  558.  
  559. *  Recherche du numero associe a la bibliotheque/fichier si existe
  560.       CALL LEXTFN(idirep,ficb,ios)
  561.       IF (ios.GT.0) THEN
  562.         iret = ios
  563.         GOTO 670
  564.       END IF
  565.  
  566. **?*  Ouverture de la bibliotheque (verification faite a l'utilisation
  567. **?*  d'une loi/fonction contenue dans la bibliotheque)
  568. **?      lgd   = LONG(sdiext.dirloi(idirep))
  569. **?      nextl = lextl(iextl)
  570. **?      lge   = lgd + lgf + nextl
  571. **?      lmeptr = 0
  572. **?      CALL PTRLIB(sdiext.dirloi(idirep)(1:lgd)//ficb(1:lgf)//
  573. **?     &            sextl(iextl)(1:nextl)//CHAR(0), lge, lmeptr)
  574. **?      IF (lmeptr.LE.0) THEN
  575. **?        iret = -3
  576. **?        iret = lmeptr
  577. **?        goto 630
  578. **?      ENDIF
  579. **?      if (logdbg) then
  580. **?        moterr = 'LEXTFA : dlopen(lmelib) -> .......... '
  581. **?        write(moterr(28:37),FMT='(I10)') lmeptr
  582. **?        call erreur(-385)
  583. **?      endif
  584.  
  585. * On ajoute la bibliotheque a la liste :
  586.       SEGACT,sloext*MOD
  587.       sloext.nloext = sloext.nloext + 1
  588.       ios   = sloext.nloext
  589.       nbloi = sloext.idrloi(/1)
  590.       IF (ios.GT.nbloi) THEN
  591.         nbloi = nbloi + 128
  592.         SEGADJ,sloext
  593.       END IF
  594.       sloext.ficloi(ios) = ' '
  595.       sloext.ficloi(ios)(1:lgf) = ficb(1:lgf)
  596.       sloext.idrloi(ios) = idirep
  597.       SEGACT,sloext*NOMOD
  598.       if (logdbg) then
  599.         moterr = '(Warning 6.0) External laws: Library added'
  600.         call erreur(-385)
  601.         CALL LEXTPR(nloext)
  602.       end if
  603. * On retourne les arguments :
  604.       inov = 1
  605.       iret = ios
  606.       GOTO 600
  607.  
  608. * Traitement des erreurs :
  609.  610  CONTINUE
  610.       if (logdbg) then
  611.         moterr = '(Warning 6.1) External laws: Library name too long'
  612.         call erreur(-385)
  613.         l = 60
  614.         moterr = ' "'//ficl(1:1+l)//'[...]'//ficl(lgf-l:lgf)//'"'
  615.         call erreur(-385)
  616. c*dbg        moterr = '=> Library not used'
  617. c*dbg        call erreur(-385)
  618.       end if
  619.       GOTO 600
  620.  620  CONTINUE
  621.       if (logdbg) then
  622.         j = lextl(iextl)
  623.         moterr = '(Warning 6.2) External laws: Library extension ('//
  624.      &           sextl(iextl)(1:j)//') not found'
  625.         call erreur(-385)
  626.         if (lgf.gt.125) then
  627.           l = 60
  628.           moterr = ' "'//ficl(1:1+l)//'[...]'//ficl(lgf-l:lgf)//'"'
  629.         else
  630.           moterr = ' "'//ficl(1:lgf)//'"'
  631.         end if
  632.         call erreur(-385)
  633. c*dbg        moterr = '=> Library not used'
  634. c*dbg        call erreur(-385)
  635.       end if
  636.       GOTO 600
  637.  630  CONTINUE
  638.       if (logdbg) then
  639.         moterr = '(Warning 6.3) External laws: Library cannot '//
  640.      &           'be opened'
  641.         call erreur(-385)
  642. c*dbg        moterr = '=> Library not used'
  643. c*dbg        call erreur(-385)
  644.       end if
  645.       GOTO 600
  646.  670  CONTINUE
  647.       if (logdbg) then
  648.         moterr = '(Warning 6.7) External laws: Library already found'
  649.         call erreur(-385)
  650.         if (lgf.gt.120) then
  651.           j = lextl(iextl)
  652.           l = 58
  653.           moterr = ' "'//ficb(1:1+l)//'[...]'//ficb(lgf-l:lgf)//
  654.      &               sextl(iextl)(1:j)//'"'
  655.         else
  656.           moterr = ' "'//ficb(1:lgf)//sextl(iextl)(1:j)//'"'
  657.         end if
  658.         call erreur(-385)
  659.         moterr = 'already found in the previous directory'
  660.         call erreur(-385)
  661.         i_z = sloext.idrloi(ios)
  662.         l_z = LONG(sdiext.dirloi(i_z))
  663.         if (l_z.gt.125) then
  664.           l = 60
  665.           moterr = ' "'//sdiext.dirloi(i_z)(1:1+l)//'[...]'//
  666.      &             sdiext.dirloi(i_z)(l_z-l:l_z)//'"'
  667.         else
  668.           moterr = ' "'//sdiext.dirloi(i_z)(1:l_z)//'"'
  669.         end if
  670.         call erreur(-385)
  671. c*dbg        moterr = '=> Library not added'
  672. c*dbg        call erreur(-385)
  673.       end if
  674.       GOTO 600
  675.  
  676.  600  CONTINUE
  677.       RETURN
  678.  
  679. *-7--------------------------------------------------------------------*
  680. *  Suppression d'un repertoire de la liste :
  681. *  (E) idirep : numero du repertoire a oter
  682. *  (S) iret   : = 1 si succes, = 0 sinon
  683. *  (E/S) segment sdiext modifie
  684. *----------------------------------------------------------------------*
  685.       ENTRY LEXTDS(idirep,iret)
  686.  
  687.       iret = 0
  688.       SEGACT,sdiext*MOD
  689.       IF (idirep.LE.0 .OR. idirep.GT.sdiext.ndiext) GOTO 700
  690.       if (logdbg) then
  691.         moterr = '(Warning 7.0) Directory removed'
  692.         call erreur(-385)
  693.         dirb = sdiext.dirloi(idirep)
  694.         lgd = LONG(dirb)
  695.         if (lgd.gt.125) then
  696.           l = 60
  697.           moterr = ' "'//dirb(1:1+l)//'[...]'//dirb(lgd-l:lgd)//'"'
  698.         else
  699.           moterr = ' "'//dirb(1:lgd)//'"'
  700.         end if
  701.         call erreur(-385)
  702.       end if
  703.       sdiext.ndiext = sdiext.ndiext - 1
  704.       DO i = idirep, ndiext
  705.         sdiext.dirloi(i) = sdiext.dirloi(i+1)
  706.       END DO
  707.       iret = 1
  708.  700  CONTINUE
  709.       SEGACT,sdiext*NOMOD
  710.  
  711.       RETURN
  712.  
  713. *-8--------------------------------------------------------------------*
  714. *  Suppression d'une bibliotheque de la liste :
  715. *  (E) idilaw : numero de la bibliotheque a oter
  716. *  (S) iret   : = 1 si succes, = 0 sinon
  717. *  (E/S) segment sloext modifie
  718. *----------------------------------------------------------------------*
  719.       ENTRY LEXTFS(idilaw,iret)
  720.  
  721.       iret = 0
  722.       SEGACT,sloext*MOD
  723.       IF (idilaw.LE.0 .OR. idilaw.GT.sloext.nloext) GOTO 800
  724.       if (logdbg) then
  725.         moterr = '(Warning 8.0) Library removed'
  726.         call erreur(-385)
  727.         ficb = sloext.ficloi(idilaw)
  728.         lgf = LONG(ficb)
  729.         if (lgf.gt.125) then
  730.           l = 60
  731.           moterr = ' "'//ficb(1:1+l)//'[...]'//ficb(lgf-l:lgf)//'"'
  732.         else
  733.           moterr = ' "'//ficb(1:lgf)//'"'
  734.         end if
  735.         call erreur(-385)
  736.       end if
  737.       sloext.nloext = sloext.nloext - 1
  738.       DO i = idilaw, nloext
  739.         sloext.ficloi(i) = sloext.ficloi(i+1)
  740.         sloext.idrloi(i) = sloext.idrloi(i+1)
  741.       END DO
  742.       iret = 1
  743.  800  CONTINUE
  744.       SEGACT,sloext*NOMOD
  745.  
  746.       RETURN
  747.  
  748. *-9--------------------------------------------------------------------*
  749. *  Recherche de la bibliotheque et ouverture de la loi demandee
  750. *----------------------------------------------------------------------*
  751.       ENTRY LEXTOP(ficl,noml,npar,iloi,iptr)
  752.  
  753.       iloi = 0
  754.       iptr = -3
  755.  
  756.       lgt = LONG(ficl)
  757. c*dbg      if (logdbg) write(ioimp,*) 'LEXTOP ='//ficl(1:lgt)//'=',lgt
  758. * ficl est de la forme "(chemin_repertoire/)fichier(.ext)"
  759.  
  760. * Recuperation du repertoire "(chemin_repertoire/)" si donne en tete :
  761.       ind = 0
  762.       DO i = 1, NBLIB
  763.         j = INDEX(ficl(1:lgt),sepa2(i)(1:1),.TRUE.)
  764.         ind = MAX(ind,j)
  765.         j = INDEX(ficl(1:lgt),sepa2(i)(2:2),.TRUE.)
  766.         ind = MAX(ind,j)
  767.       END DO
  768. c*dbg      if (logdbg) write(ioimp,*) '(LEXTOP) Recherche repertoire',ind
  769.       IF (ind.GT.0) THEN
  770.         if (ind.gt.LOCHAI) then
  771.           moterr = 'LEXTOP(0.1) Directory name too long - Very strange!'
  772.           call erreur(-385)
  773.           call erreur(5)
  774.           return
  775.         endif
  776.         CALL LEXTDA(ficl(1:ind),ios,inew)
  777.         idiext = ios
  778. c*dbg      if (logdbg) write(ioimp,*) '(LEXTOP) Repertoire',ind,idiext
  779.         IF (ios.LE.0) GOTO 910
  780.         IF (ios.GT.0 .AND. inew.NE.0) THEN
  781.           CALL LEXTDC(idiext,ios)
  782.           IF (ios.LT.0) GOTO 910
  783.         ENDIF
  784.       ELSE
  785.         idiext = 0
  786.       ENDIF
  787. c*dbg      if (logdbg) write(ioimp,*) '(LEXTOP) Repertoire',ind,idiext
  788.  
  789. *  Analyse de la bibliotheque/fichier "fichier(.ext)" :
  790.       lgf = lgt - ind
  791. c*dbg      if (logdbg) write(ioimp,*) '(LEXTOP) Recherche fichier',lgf
  792.       if      (lgf.LE.0) then
  793.         moterr = 'LEXTOP(1.1) Null size Library Name!'
  794.         call erreur(-385)
  795.         call erreur(21)
  796.         return
  797.       else if (lgf.gt.LOCHAI) then
  798.         moterr = 'LEXTOP(1.2) Library Name too long-Very strange!'
  799.         call erreur(-385)
  800.         call erreur(5)
  801.         return
  802.       end if
  803.  
  804.       ficb = ' '
  805.       ficb = ficl(ind+1:lgt)
  806.       ideb = 1
  807.       ifin = lgf
  808.       CALL LEXTFA(idiext,ficb(ideb:ifin),.FALSE.,ios,inew)
  809. c*dbg      write(ioimp,*) 'LEXTFA :',idiext,ios,inew
  810.       idiloi = ios
  811.       IF (inew.EQ.1) THEN
  812.         CALL LEXTFS(idiloi,ios)
  813.         idiloi = 0
  814.       ENDIF
  815.       IF (idiloi.LE.0) THEN
  816. %IF WIN32,WIN64
  817.         CALL CHCASS(ficb(1:3),0,dirb(1:3))
  818. %ELSE
  819.         dirb(1:3) = ficb(1:3)
  820. %ENDIF
  821.         IF (dirb(1:3).EQ.'lib') THEN
  822.           ideb = 1+3
  823.           CALL LEXTFA(idiext,ficb(ideb:ifin),.FALSE.,ios,inew)
  824.         ELSE
  825.           if (lgf+3.gt.LOCHAI) GOTO 920
  826.           CALL LEXTFA(idiext,'lib'//ficb(ideb:ifin),.FALSE.,ios,inew)
  827.         END IF
  828.         idiloi = ios
  829.         IF (inew.EQ.1) THEN
  830.           CALL LEXTFS(idiloi,ios)
  831.           idiloi = 0
  832.         ENDIF
  833.       END IF
  834.       IF (idiloi.LE.0) GOTO 930
  835. * Librairie trouvee
  836.       ficl = sloext.ficloi(ios)(1:lgf)
  837.       iloi = ios
  838.       if (logdbg) call lextpr(ios)
  839.  
  840.       lgn  = LONG(noml)
  841.       if      (lgn.LE.0) then
  842.         moterr = 'LEXTOP(3.1) Null Size String!'
  843.         call erreur(-385)
  844.         call erreur(5)
  845.         return
  846.       else if (lgn.gt.LOCHAI) then
  847.         moterr = 'LEXTOP(3.2) String too long - Very strange!'
  848.         call erreur(-385)
  849.         call erreur(5)
  850.         return
  851.       end if
  852.  
  853. **      SEGACT,sloext*NOMOD
  854.       idi  = sloext.idrloi(ios)
  855.       lgd  = LONG(sdiext.dirloi(idi))
  856.       lgf  = LONG(sloext.ficloi(ios))
  857.       nextl = lextl(iextl)
  858.       lge  = lgd + lgf + nextl
  859.       entr = ' '
  860.       entr(1:lgd)         = sdiext.dirloi(idi)(1:lgd)
  861.       entr(lgd+1:lgd+lgf) = sloext.ficloi(ios)(1:lgf)
  862.       entr(lgd+lgf+1:lge) = sextl(iextl)(1:nextl)
  863.       ip     = npar
  864.       lmeptr = 0
  865.       CALL PTRLOI(entr(1:lge)//CHAR(0),lge, noml(1:lgn)//CHAR(0),lgn,
  866.      &            ip, lmeptr)
  867.       iptr = lmeptr
  868.       IF (lmeptr.LE.0) GOTO 940
  869.       GOTO 900
  870.  
  871. * Traitements des erreurs
  872.  910  CONTINUE
  873.       moterr = '(Error 9.0) Incorrect Directory "DIR_LOI"'
  874.       call erreur(-385)
  875.       if (ind.gt.125) then
  876.         l = 60
  877.         moterr = ' "'//ficl(1:1+l)//'[...]'//ficl(ind-l:ind)//'"'
  878.       else
  879.         moterr = ' "'//ficl(1:ind)//'"'
  880.       endif
  881.       call erreur(-385)
  882.       call erreur(21)
  883.       GOTO 900
  884.  920  CONTINUE
  885.       moterr = '(Error 9.1) "FCT_LOI" Library name too long'
  886.       call erreur(-385)
  887.       if (lgf.gt.122) then
  888.         l = 58
  889.         moterr = ' "lib'//ficb(1:1+l)//'[...]'//ficb(lgf-l:lgf)//'"'
  890.       else
  891.         moterr = ' "lib'//ficb(1:lgf)//'"'
  892.       end if
  893.       call erreur(-385)
  894.       call erreur(21)
  895.       GOTO 900
  896.  930  CONTINUE
  897.       moterr = '(Error 9.2) "FCT_LOI" Library not found'
  898.       call erreur(-385)
  899.       if (lgf.gt.120) then
  900.         l = 56
  901.         moterr = ' "(lib)'//ficb(1:1+l)//'[...]'//ficb(lgf-l:lgf)//'"'
  902.       else
  903.         moterr = ' "(lib)'//ficb(1:lgf)//'"'
  904.       end if
  905.       call erreur(-385)
  906.       call erreur(21)
  907.       GOTO 900
  908.  940  CONTINUE
  909.       moterr = ' '
  910.       i_z = min(32,lgn)
  911.       moterr(1 :i_z) = noml(1:i_z)
  912.       i_z = MIN(32,lgf)
  913.       moterr(32+1:32+i_z) = entr(lgd+1:lgd+i_z)
  914.       i_z = MIN(64,lgd)
  915.       moterr(64+1:64+i_z) = entr(1:i_z)
  916.       call erreur(1113)
  917.       GOTO 900
  918.  
  919.  900  CONTINUE
  920.       RETURN
  921.  
  922. *-9--------------------------------------------------------------------*
  923. *  Affichage d'une ou de toutes les lois trouvees :
  924.       ENTRY LEXTPR(iret)
  925.  
  926. * iret = 0 : affichage d'un recapitulatif complet
  927. * iret > 0 : affichage de la bibliotheque de numero iret
  928.       IF (sdiext.ndiext.LE.0) RETURN
  929.       IF (nloext.LE.0) RETURN
  930.       IF (iret.LT.0 .OR. iret.GT.nloext) RETURN
  931.  
  932. * Travail sur les formats d'affichage
  933.       entr ='(A,I ) (A,I ,A) (A,I ) (A,I ,A)'
  934. **           1   56 8   1  1 1   22 2   2  3
  935. **                      2  5 7   12 4   8  1
  936.       id = INT(LOG10(REAL(sdiext.ndiext))) + 1
  937.       if (id.lt.1 .or. id.gt.6) then
  938.         moterr = '(Error) Too many directories'
  939.         call erreur(-385)
  940.         call erreur(5)
  941.         return
  942.       end if
  943.       il = INT(LOG10(REAL(nloext))) + 1
  944.       if (il.lt.1 .or. il.gt.6) then
  945.         moterr = '(Error) Too many libairies'
  946.         call erreur(-385)
  947.         call erreur(5)
  948.         return
  949.       end if
  950.       write(entr( 5: 5),FMT='(I1)') id
  951.       write(entr(12:12),FMT='(I1)') id
  952.       write(entr(21:21),FMT='(I1)') il
  953.       write(entr(28:28),FMT='(I1)') il
  954.  
  955. * Bornes de la boucle d'affichage des bibliotheques
  956.       IF (iret.EQ.0) THEN
  957.         ideb = 1
  958.         ifin = nloext
  959.       ELSE
  960.         ideb = iret
  961.         ifin = iret
  962.       END IF
  963.  
  964. * Affichage de l'entete selon la demande :
  965.       IF (iret.EQ.0) THEN
  966.         write(ioimp,*)
  967.         write(ioimp,*) 'External Laws Summary:'
  968.         write(ioimp,*) '----------------------'
  969.       if (logdbg) then
  970.         write(ioimp,fmt=entr(1:6))
  971.      &              ' Number of directories found: ',sdiext.ndiext
  972.         write(ioimp,*) '----------------------'
  973.         DO i = 1, sdiext.ndiext
  974.           dirb = sdiext.dirloi(i)
  975.           lgd  = LONG(dirb)
  976.           write(ioimp,fmt=entr(8:15))
  977.      &                ' Dir.#',i,' "'//dirb(1:lgd)//'"'
  978.         END DO
  979.         write(ioimp,*) '----------------------'
  980.       end if
  981.         nextl = lextl(iextl)
  982.         write(ioimp,fmt=entr(17:22))
  983.      &              ' Number of libraries ('//sextl(iextl)(1:nextl)//
  984.      &              ') found: ',nloext
  985.         write(ioimp,*) '----------------------'
  986.       ELSE
  987.       END IF
  988.  
  989.       if (logdbg) then
  990.       DO i = ideb, ifin
  991.         idi = sloext.idrloi(i)
  992.         lgd = LONG(sdiext.dirloi(idi))
  993.         lgf = LONG(sloext.ficloi(i))
  994.  
  995.         write(ioimp,FMT=entr(17:22)) ' External Law Library #',i
  996.         write(ioimp,*) ' - Name "'//sloext.ficloi(i)(1:lgf)//'"'
  997.         write(ioimp,*) ' - Dir. "'//sdiext.dirloi(idi)(1:lgd)//'"'
  998.       END DO
  999.       end if
  1000.  
  1001.       IF (iret.EQ.0) THEN
  1002.         write(ioimp,*)
  1003.         write(ioimp,*) '***********************************************'
  1004.      &               //'************************'
  1005.         write(ioimp,*)
  1006.       ELSE
  1007.       END IF
  1008.       write(ioimp,*)
  1009.  
  1010.       RETURN
  1011.  
  1012. *----------------------------------------------------------------------*
  1013.       END
  1014.  
  1015.  

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