[Search for users]
[Overall Top Noters]
[List of all Conferences]
[Download this site]
| Title: | Digital Fortran |
| Notice: | Read notes 1.* for important information |
| Moderator: | QUARK::LIONEL |
|
| Created: | Thu Jun 01 1995 |
| Last Modified: | Fri Jun 06 1997 |
| Last Successful Update: | Fri Jun 06 1997 |
| Number of topics: | 1333 |
| Total number of notes: | 6734 |
1210.0. "Problem with adjustable arrays on Alpha." by PRSSOS::MAILLARD (Denis MAILLARD) Wed Mar 05 1997 07:45
One of my customers just reported me a problem he encountered in porting
an application from DEC Fortran VAX to Digital Fortran Alpha.
On VAX the code compiles smoothly, links without problem with the
appropriate other objects and has been running for years.
The compilation of the offending module with DEC Fortran V6.3-160 on VAX
(VMS V6.2) just gives the following informative diagnostics, coming from
variables that are used by other modules:
%FORT-I-VARUNUSED, Variable was declared but not used
[HLP_WORKSPACE] in module ECRSTD
%FORT-I-VARUNUSED, Variable was declared but not used
[TROUVE] in module ECRSTD
%FORT-I-VARUNUSED, Variable was declared but not used
[RELCUR] in module ECRSTD
%FORT-I-VARUNUSED, Variable was declared but not used
[TYPCUR] in module ECRSTD
%FORT-I-VARUNUSED, Variable was declared but not used
[CODVID] in module ECRSTD
%FORT-I-VARUNUSED, Variable was declared but not used
[NOMCUR] in module ECRSTD
%FORT-I-VARUNUSED, Variable was declared but not used
[NTAB] in module NGETTAB
%FORT-I-VARUNUSED, Variable was declared but not used
[SNTAB] in module NGETTAB
%FORT-I-ENDDIAGS, USERS3:[MAILLARD.GEC]PB.FOR;1 completed with 8 diagnostics
On Alpha (VMS V7.1), with Digital Fortran 77 V7.1-107, the compilation
gives 12 warnings (4 %FORT-W-NOVALUE, 4 %FORT-W-NOEPDEFDA and 4
%FORT-W-DAUNDEFEP).
The module merely defines subroutines, using the ENTRY statement. At
execution on Alpha, the adjustable arrays passed as arguments are seen with
dimension 0, leading to application failures.
I don't understand what's wrong in the program. Could someone more
learned in Fortran than I am tell me whether this comes from a programming error
or if I should report a compiler problem, please?
Following come first the output of the Alpha compilation, then four
small include files referenced by the module, then the Fortran module (PB.FOR).
Thanks for any input,
Denis.
========================================================================
Alpha Compilation output
========================================================================
$ fort pb
VALS( POSCUR)( IND_DEB:IND_FIN) = ' '
...........^
%FORT-W-NOVALUE, No value
at line number 646 in file USERS3:[MAILLARD.GEC]PB.FOR;1
VALS( POSCUR)( IND_DEB:IND_FIN) = ' '
...........^
%FORT-W-NOEPDEFDA, No entry point leading to this statement defines dummy argument VALS
at line number 646 in file USERS3:[MAILLARD.GEC]PB.FOR;1
SAVS( POSCUR)( IND_DEB:IND_FIN) = ' '
...........^
%FORT-W-NOVALUE, No value
at line number 647 in file USERS3:[MAILLARD.GEC]PB.FOR;1
SAVS( POSCUR)( IND_DEB:IND_FIN) = ' '
...........^
%FORT-W-NOEPDEFDA, No entry point leading to this statement defines dummy argument SAVS
at line number 647 in file USERS3:[MAILLARD.GEC]PB.FOR;1
CALL TGETTAB( VALS, SVALS)
.....................^
%FORT-W-DAUNDEFEP, Dummy argument VALS is undefined at entry point VALCHP
at line number 575 in file USERS3:[MAILLARD.GEC]PB.FOR;1
CALL FDV$GETAL (,RETKEY,NOMS(CODCHP),IND )
....................................^
%FORT-W-NOVALUE, No value
at line number 533 in file USERS3:[MAILLARD.GEC]PB.FOR;1
CALL FDV$GETAL (,RETKEY,NOMS(CODCHP),IND )
....................................^
%FORT-W-NOEPDEFDA, No entry point leading to this statement defines dummy argument NOMS
at line number 533 in file USERS3:[MAILLARD.GEC]PB.FOR;1
CALL FDV$GETAL (,RETKEY,NOMS(CODCHP),IND )
....................................^
%FORT-W-NOEPDEFDA, No entry point leading to this statement defines dummy argument NOMS
at line number 533 in file USERS3:[MAILLARD.GEC]PB.FOR;1
CALL TGETTAB( FORMS, SFORMS)
.....................^
%FORT-W-DAUNDEFEP, Dummy argument FORMS is undefined at entry point N2TECR
at line number 438 in file USERS3:[MAILLARD.GEC]PB.FOR;1
CALL TGETTAB( FORMS, SFORMS)
.....................^
%FORT-W-NOVALUE, No value
at line number 438 in file USERS3:[MAILLARD.GEC]PB.FOR;1
CALL TGETTAB( FORMS, SFORMS)
.....................^
%FORT-W-DAUNDEFEP, Dummy argument FORMS is undefined at entry point N2TECR
at line number 438 in file USERS3:[MAILLARD.GEC]PB.FOR;1
CALL TGETTAB( SAVS, SSAVS)
.....................^
%FORT-W-DAUNDEFEP, Dummy argument SAVS is undefined at entry point MODECR
at line number 337 in file USERS3:[MAILLARD.GEC]PB.FOR;1
========================================================================
Include file C_DEFKEY.INC
========================================================================
C
C Commun "DEFKEY"
C Contient les numeros des differentes touches fonction
C utilisables sur un ecran a un moment donne
C
C NBR_MAXKEY : Nombre de touches valides
C TAB_VALKEY : Table contenant les numeros des touches valides
C VAL_RETKEY : Numero de la touche saisie par l'utilisateur
C ( mis a jour par l'UAR UVALKEY )
C
C
INTEGER NBR_MAXKEY, VAL_RETKEY,TAB_VALKEY(30),LASTKEY
CHARACTER *1 FLG_VAL
C
COMMON /DEFKEY/ NBR_MAXKEY, TAB_VALKEY, VAL_RETKEY , LASTKEY,
& FLG_VAL
========================================================================
Include file C_ERRNUM.INC
========================================================================
C
C Commun "ERRNUM"
C Contient les status des differentes erreurs
C TAB_STATUS : Status de retour pour les acces aux tables
C IO_STATUS : " " " pour les entrees/sorties
C FMS_STATUS : Status d'erreur FMS
C RMS_STATUS : " " RMS
C CUR_STATUS : Flag logique indiquant le statut d'erreur courant
C GEN_STATUS : " " " " " " general
C
INTEGER *2 TAB_STATUS, IO_STATUS
INTEGER *4 FMS_STATUS, RMS_STATUS
LOGICAL CUR_STATUS, GEN_STATUS
COMMON /ERRNUM/ TAB_STATUS, IO_STATUS, FMS_STATUS, RMS_STATUS,
1 CUR_STATUS, GEN_STATUS
========================================================================
Include file C_FDVDEF.INC
========================================================================
C
C Commun FDVDEF
C Contient les valeurs des touches du clavier
C ainsi que les codes retour des UAR
C
C Touches PF1_X ( X = 1 --> 9 )
C
INTEGER FDV$K_G_0, FDV$K_G_1, FDV$K_G_2, FDV$K_G_3,
1 FDV$K_G_4, FDV$K_G_5, FDV$K_G_6, FDV$K_G_7,
2 FDV$K_G_8, FDV$K_G_9, FDV$K_G_MNS,
3 FDV$K_G_EQ
C
C Touches PF1_X ( X = A --> Z )
C
INTEGER FDV$K_G_A, FDV$K_G_B, FDV$K_G_C, FDV$K_G_D,
1 FDV$K_G_E, FDV$K_G_F, FDV$K_G_G, FDV$K_G_H,
2 FDV$K_G_I, FDV$K_G_J, FDV$K_G_K, FDV$K_G_L,
3 FDV$K_G_M, FDV$K_G_N, FDV$K_G_O, FDV$K_G_P,
4 FDV$K_G_Q, FDV$K_G_R, FDV$K_G_S, FDV$K_G_T,
5 FDV$K_G_U, FDV$K_G_V, FDV$K_G_W, FDV$K_G_X,
6 FDV$K_G_Y, FDV$K_G_Z
C
C Touches "Fonctions" ( F7,F8,F9,F10,F17,F18,F19,F20,
C TABULATION,BACKTAB,UP ARROW,
C DOWN ARROW,AUTOTAB )
C
INTEGER PGP, PGS, ECP, ECS, VAL, PPG, REI, ABD, NXT, PRV,
1 TAB, BKT, UPA, DNA, AUT
C
C Codes retour des UAR
C
INTEGER FDV$K_UVAL_FAIL, FDV$K_UVAL_END,
1 FDV$K_UKEY_ERR, FDV$K_UKEY_TRM, FDV$K_UKEY_NXT,
2 FDV$K_UKEY_NTR, FDV$K_UKEY_SUC
C
C Code retour d'erreur
C
INTEGER FDV$_SUC, FDV$_MOD
C
C Workspace des ecrans d'aide
C
CHARACTER *2000 HLP_WORKSPACE
C
COMMON/FDVDEF/FDV$K_G_0, FDV$K_G_1, FDV$K_G_2, FDV$K_G_3,
1 FDV$K_G_4, FDV$K_G_5, FDV$K_G_6, FDV$K_G_7,
2 FDV$K_G_8, FDV$K_G_9, FDV$K_G_MNS, FDV$K_G_EQ,
3 FDV$K_G_A, FDV$K_G_B, FDV$K_G_C, FDV$K_G_D,
4 FDV$K_G_E, FDV$K_G_F, FDV$K_G_G, FDV$K_G_H,
5 FDV$K_G_I, FDV$K_G_J, FDV$K_G_K, FDV$K_G_L,
6 FDV$K_G_M, FDV$K_G_N, FDV$K_G_O, FDV$K_G_P,
7 FDV$K_G_Q, FDV$K_G_R, FDV$K_G_S, FDV$K_G_T,
8 FDV$K_G_U, FDV$K_G_V, FDV$K_G_W, FDV$K_G_X,
9 FDV$K_G_Y, FDV$K_G_Z, TAB, BKT, UPA, DNA,
A PGP, PGS, ECP, ECS, VAL, PPG, REI, ABD, NXT, PRV,
B AUT, FDV$K_UVAL_FAIL, FDV$K_UVAL_END,
C FDV$K_UKEY_ERR, FDV$K_UKEY_TRM, FDV$K_UKEY_NXT,
D FDV$K_UKEY_NTR, FDV$K_UKEY_SUC, FDV$_SUC, FDV$_MOD
========================================================================
Include file G_ECRAPP.INC
========================================================================
C
INTEGER CECR_A
PARAMETER ( CECR_A = 1 )
C
INTEGER CECR_LA
PARAMETER ( CECR_LA = 2 )
C
INTEGER CECR_L
PARAMETER ( CECR_L = 3 )
C
INTEGER CECR_TXT
PARAMETER ( CECR_TXT = 4 )
C
INTEGER CECR_ENTNOR
PARAMETER ( CECR_ENTNOR = 5 )
C
INTEGER CECR_RELNOR
PARAMETER ( CECR_RELNOR = 6 )
C
INTEGER CECR_VIDNOR
PARAMETER ( CECR_VIDNOR = -1)
C
INTEGER CECR_VIDERR
PARAMETER ( CECR_VIDERR = 13)
C
INTEGER CECR_SUCCES
PARAMETER ( CECR_SUCCES = 1000 ) ! CODE SUCCES = FDV$K_UVAL_SUC
C
INTEGER CECR_ECHEC
PARAMETER ( CECR_ECHEC = 1001 ) ! CODE ECHEC = FDV$K_UVAL_FAIL
========================================================================
Problem Module PB.FOR
========================================================================
!
SUBROUTINE ECRSTD
!---------------
!
IMPLICIT NONE
!...Include...
!-------------
INCLUDE 'C_ERRNUM.INC'
INCLUDE 'C_FDVDEF.INC'
INCLUDE 'C_DEFKEY.INC'
INCLUDE 'G_ECRAPP.INC'
!
!... Arguments
!
INTEGER ANBZON !..Nombre de zones dans l'ecran..
!
!... Variables de travail
!
LOGICAL FLGINIT !..Flag de reinisialisation
LOGICAL FLGFIRST !..Flag de premier passage dans un ecran
LOGICAL FLGWAIT !..Flag d'attente apres un message d'information
LOGICAL TROUVE !..Recherche du nom courant
!
INTEGER I !..Compteurs..
INTEGER IND !..Indice de position dans une serie de meme noms..
INTEGER IND_DEB !..Indice de debut dans VALS du texte du champ courant ..
INTEGER IND_FIN !..Indice de fin dans VALS du texte du champ courant ..
INTEGER NBZON !..Nombre de zones dans l'ecran..
INTEGER TECR !..Taille memoire allouee a l'ecran..
INTEGER CODCHP !..Indice de tableau..
INTEGER RESULT !..Code de comparaison entre valeur et sauvegarde..
INTEGER RETKEY !..Code de la touche entree par l'utilisateur..
INTEGER POSCUR !..Position du curseur..
INTEGER NUMCUR !..Entier courant (retourne par NUMCHP)..
REAL RELCUR !..Reel courant (retourne par RELCHP)..
INTEGER TYPCUR !..Type courant (retourne par TYPCHP)..
INTEGER CODVID
INTEGER BLINKBOLD !..Attribut video...
!
CHARACTER *80 NOMCUR !..Nom du champ courant retourne par FMS
CHARACTER *(*) NECR !..Nom de l'ecran a charger..
CHARACTER *(*) WSP
CHARACTER *80 STRING !..Variable de travail..
!
!...Tableau des infomatons textuelles
! des champs d'un ecran...
!------------------------------------
!...
CHARACTER *(*) VALS
DIMENSION VALS(*)
INTEGER SVALS
DIMENSION SVALS( 2)
!
CHARACTER *(*) VALCUR
!
!...Tableau de sauvegarde des valeurs affichees...
!-------------------------------------------------
!
CHARACTER *(*) SAVS
DIMENSION SAVS(*)
INTEGER SSAVS
DIMENSION SSAVS(2)
!
!...Tableau des noms de zones d'ecran FMS...
!-------------------------------------------
!
CHARACTER *(*) NOMS
DIMENSION NOMS(*)
INTEGER SNOMS
DIMENSION SNOMS(2)
!
!...Tableau de controle des ecritures :
! affichable ou lecture/affichable...
!---------------------------------------
!
INTEGER AECRS
DIMENSION AECRS(*)
INTEGER ECRS
DIMENSION ECRS(1000)
POINTER (SECRS, ECRS)
!
!...Tableau d'indice de champs de meme noms...
!---------------------------------------------
!
INTEGER AINDS
DIMENSION AINDS(*)
INTEGER INDS
DIMENSION INDS(1000)
POINTER (SINDS, INDS)
!
!...Tableau des valeurs numeriques INTEGER...
!--------------------------------------------
!
INTEGER ANUMS
DIMENSION ANUMS(*)
INTEGER NUMS
DIMENSION NUMS( 1000)
POINTER (SNUMS, NUMS)
!
!...Tableau des valeurs numeriques REAL...
!--------------------------------------------
!
REAL ARELS
DIMENSION ARELS(*)
REAL RELS
DIMENSION RELS(1000)
POINTER (SRELS, RELS)
!
!...Tableau de type des champs : numerique ou caractere...
!---------------------------------------------------------
!
INTEGER ATYPS
DIMENSION ATYPS(*)
INTEGER TYPS
DIMENSION TYPS(1000)
POINTER (STYPS, TYPS)
!
!...Tableau de taille des champs.
!--------------------------------
!
INTEGER ASIZS
DIMENSION ASIZS(*)
INTEGER SIZS
DIMENSION SIZS(1000)
POINTER (SSIZS, SIZS)
!
!...Tableau des formes pour les conversions...
!---------------------------------------------
!
CHARACTER *(*) FORMS
DIMENSION FORMS(*)
INTEGER SFORMS
DIMENSION SFORMS(2)
!
!...Libelle du message...
!------------------------
!
CHARACTER *(*) LIBL
!
SAVE
C---------------------------------------------------------------------
!
!==============================================================
! INITIALISATION D'UN ECRAN =
!==============================================================
!
ENTRY INIECR( FLGFIRST,ANBZON, TECR, NECR, WSP,VALS,SAVS,NOMS,
& AECRS,AINDS,FORMS,ANUMS,ARELS,ATYPS,ASIZS, *)
!-------------------------------------------------------------
!
NBZON = ANBZON
IF ( FLGFIRST ) THEN
CALL FDV$AWKSP( WSP, TECR)
IF (FMS_STATUS .NE. FDV$_SUC) RETURN 1
CALL FDV$LOAD( NECR)
IF (FMS_STATUS .NE. FDV$_SUC) RETURN 1
ELSE
CALL FDV$SWKSP ( WSP )
IF (FMS_STATUS .NE. FDV$_SUC) RETURN 1
ENDIF
!
CALL TSAVTAB( VALS, SVALS)
CALL TSAVTAB( SAVS, SSAVS)
CALL TSAVTAB( NOMS, SNOMS)
CALL TSAVTAB( FORMS, SFORMS)
CALL NSAVTAB( AINDS, SINDS)
CALL NSAVTAB( AECRS, SECRS)
CALL NSAVTAB( ANUMS, SNUMS)
CALL NSAVTAB( ARELS, SRELS)
CALL NSAVTAB( ATYPS, STYPS)
CALL NSAVTAB( ASIZS, SSIZS)
!
!..fin..
!
RETURN
!
C---------------------------------------------------------------------
!
!==============================================================
! TERMINAISON D'UN ECRAN =
!==============================================================
!
ENTRY FINECR( WSP, * )
!---------------------
!
!
CALL FDV$DWKSP ( WSP )
IF (FMS_STATUS .NE. FDV$_SUC) RETURN 1
!
!..fin..
!
RETURN
!
C--------------------------------------------------------------------
!=============================================================
! ROUTINES D'ECRITURE =
!=============================================================
!
!
ENTRY ECRECR( * )
!----------------------------------------------
!
! Affichage des zones ecrans
!
CALL NGETTAB( ECRS, SECRS)
CALL TGETTAB( SAVS, SSAVS)
CALL NGETTAB( NUMS, SNUMS)
CALL NGETTAB( RELS, SRELS)
CALL TGETTAB( VALS, SVALS)
CALL NGETTAB( INDS, SINDS)
CALL NGETTAB( SIZS, SSIZS)
CALL TGETTAB( NOMS, SNOMS)
C
DO I = 1, NBZON
IF ( ECRS(I) .EQ. CECR_A .OR.
1 ECRS(I) .EQ. CECR_LA )
2 THEN
IF ( INDS( I) .EQ. 0) THEN
IND_DEB = 1
IND_FIN = SIZS( I)
POSCUR = I
ELSE
IF ( INDS( I) .EQ. 1) THEN
POSCUR = I
END IF
IND_DEB = ( ( I - POSCUR) * SIZS( I)) + 1
IND_FIN = IND_DEB + SIZS( I) - 1
END IF
IF ( (SAVS(POSCUR)(IND_DEB:IND_FIN) .NE.
1 VALS(POSCUR)(IND_DEB:IND_FIN)) .OR. FLGINIT )
2 THEN
IF (( TYPS(I) .EQ. CECR_ENTNOR .AND.
& NUMS(I) .EQ. 0) .OR.
& ( TYPS(I) .EQ. CECR_RELNOR .AND.
& RELS(I) .EQ. 0.0) )
& THEN
CALL FDV$PUTD( NOMS(I),INDS(I) )
ELSE
CALL FDV$PUT( VALS(POSCUR)(IND_DEB:IND_FIN ),
1 NOMS( I), INDS(I))
ENDIF
IF (FMS_STATUS .NE. FDV$_SUC) RETURN 1
END IF
ENDIF
END DO
!
! Copie des VALS dans SAVS
!
DO I = 1, NBZON
SAVS( I) = VALS( I)
END DO
!
FLGINIT = .FALSE.
!..fin..
!
RETURN
!
C---------------------------------------------------------------------
!
!==============================================================
! ROUTINES DE LECTURE
!==============================================================
!
ENTRY LITECR( * )
!---------------------------------------
!
! Restauration du contexte
!
CALL TGETTAB( VALS, SVALS)
CALL TGETTAB( NOMS, SNOMS)
CALL NGETTAB( INDS, SINDS)
CALL NGETTAB( SIZS, SSIZS)
CALL NGETTAB( ECRS, SECRS)
!
DO I = 1, NBZON
IF ( (ECRS(I) .EQ. CECR_L)
1 .OR. (ECRS(I) .EQ. CECR_LA))
2 THEN
IF ( INDS( I) .EQ. 0) THEN
IND_DEB = 1
IND_FIN = SIZS( I)
POSCUR = I
ELSE
IF ( INDS( I) .EQ. 1) THEN
POSCUR = I
END IF
IND_DEB = ( ( I - POSCUR) * SIZS( I)) + 1
IND_FIN = IND_DEB + SIZS( I) - 1
END IF
!
CALL FDV$RET( VALS( POSCUR)(IND_DEB: IND_FIN),
1 NOMS( I), INDS( I))
IF (FMS_STATUS .NE. FDV$_SUC) RETURN 1
ENDIF
END DO
!
!..fin..
!
RETURN
!
C---------------------------------------------------------------------
!
!==============================================================
! ROUTINES DE TEST DE MODIFICATION
!==============================================================
!
ENTRY MODECR( RESULT, IND )
!--------------------------------------------------
!
! Restauration du contexte
!
CALL TGETTAB( VALS, SVALS)
CALL TGETTAB( NOMS, SNOMS)
CALL NGETTAB( INDS, SINDS)
CALL NGETTAB( ECRS, SECRS)
CALL NGETTAB( SIZS, SSIZS)
CALL TGETTAB( SAVS, SSAVS)
!
RESULT = 0
IND = 0
I = 1
DO WHILE ((RESULT.EQ.0) .AND. (I.LE.NBZON))
IF( ECRS( I).EQ.CECR_L .OR. ECRS( I).EQ.CECR_LA) THEN
IF ( INDS( I) .EQ. 0) THEN
IND_DEB = 1
IND_FIN = SIZS( I)
POSCUR = I
ELSE
IF ( INDS( I) .EQ. 1) THEN
POSCUR = I
END IF
IND_DEB = ( ( I - POSCUR) * SIZS( I)) + 1
IND_FIN = IND_DEB + SIZS( I) - 1
END IF
IF ( VALS( POSCUR)( IND_DEB:IND_FIN) .EQ.
1 SAVS( POSCUR)( IND_DEB:IND_FIN) )
2 THEN
RESULT = I
END IF
ENDIF
I = I + 1
END DO
!
IF (RESULT.NE.0) THEN
IND = INDS( RESULT)
RESULT = RESULT + 1 - IND
ENDIF
!
!..fin..
!
RETURN
!
!
C---------------------------------------------------------------------
!
!==============================================================
! ROUTINES DE CONVERSION
!==============================================================
!--------------------------------------------------------------
! Conversion de tous les champ d'un ecran de type texte
! en type numerique
!--------------------------------------------------------------
!
ENTRY T2NECR ()
!-------------------------------------
!
! Restauration du contexte
!
CALL TGETTAB( VALS, SVALS)
CALL NGETTAB( NUMS, SNUMS)
CALL NGETTAB( RELS, SRELS)
CALL TGETTAB( FORMS, SFORMS)
CALL NGETTAB( TYPS, STYPS)
!
DO I = 1, NBZON
IF ( INDS( I) .EQ. 0) THEN
IND_DEB = 1
IND_FIN = SIZS( I)
POSCUR = I
ELSE
IF ( INDS( I) .EQ. 1) THEN
POSCUR = I
END IF
IND_DEB = ( ( I - POSCUR) * SIZS( I)) + 1
IND_FIN = IND_DEB + SIZS( I) - 1
END IF
!
IF (TYPS(I) .EQ. CECR_ENTNOR) THEN
READ( VALS(POSCUR)(IND_DEB:IND_FIN), FORMS(I),ERR=4000)
& NUMS(I)
ELSE IF (TYPS(I) .EQ. CECR_RELNOR) THEN
CALL ADDDOT( VALS( POSCUR)( IND_DEB:IND_FIN),
1 FORMS( I), STRING)
READ( STRING, FORMS(I),ERR=4000 ) RELS(I)
ENDIF
!
4000 CONTINUE
!
END DO
!
!..fin..
!
RETURN
!
!--------------------------------------------------------------
! Conversion de tous les champ d'un ecran de type
! numerique en type texte
!---------------------------------------------------------------
!
ENTRY N2TECR ()
!-------------------------------------
!
! Restauration du contexte
!
CALL TGETTAB( VALS, SVALS)
CALL NGETTAB( NUMS, SNUMS)
CALL NGETTAB( RELS, SRELS)
CALL TGETTAB( FORMS, SFORMS)
CALL NGETTAB( TYPS, STYPS)
CALL NGETTAB( SIZS, SSIZS)
!
DO I = 1, NBZON
IF ( INDS( I) .EQ. 0) THEN
IND_DEB = 1
IND_FIN = SIZS( I)
POSCUR = I
ELSE
IF ( INDS( I) .EQ. 1) THEN
POSCUR = I
END IF
IND_DEB = ( ( I - POSCUR) * SIZS( I)) + 1
IND_FIN = IND_DEB + SIZS( I) - 1
END IF
!
IF (TYPS(I) .EQ. CECR_ENTNOR ) THEN
WRITE( VALS( POSCUR)(IND_DEB:IND_FIN),FORMS(I),
1 ERR=1000) NUMS(I)
ELSE IF (TYPS(I) .EQ. CECR_RELNOR) THEN
!
WRITE( STRING, FORMS(I),ERR=1000 ) RELS(I)
CALL REMDOT( STRING, FORMS( I),
1 VALS( POSCUR)( IND_DEB:IND_FIN) )
ENDIF
!
1000 CONTINUE
!
END DO
!
!..fin..
!
RETURN
!
C---------------------------------------------------------------------
!
!==============================================================
! LA VIDEO
!==============================================================
!
!--------------------------------------------------------------
! Routine de changement d'attribut VIDEO pour tous les
! champs d'un ecran
!--------------------------------------------------------------
!
ENTRY VIDECR ( BLINKBOLD,* )
!------------------------------------------
!
! Restauration du contexte
!
CALL NGETTAB( INDS, SINDS)
CALL NGETTAB( ECRS, SECRS)
CALL TGETTAB( NOMS, SNOMS)
!
DO I = 1,NBZON
IF ( ECRS(I) .EQ. CECR_LA ) THEN
CALL FDV$AFVA ( BLINKBOLD ,NOMS(I),INDS(I) )
IF (FMS_STATUS .NE. FDV$_SUC) RETURN 1
ENDIF
END DO
!
!..fin..
!
RETURN
!
C---------------------------------------------------------------------
!
!==============================================================
! AFFICHAGE D'UN ECRAN
!==============================================================
!
ENTRY AFFECR (*)
!---------------
!
CALL FDV$DISP
IF (FMS_STATUS .NE. FDV$_SUC) RETURN 1
CALL FDV$DISPW
IF (FMS_STATUS .NE. FDV$_SUC) RETURN 1
!
RETURN
!
C----------------------------------------------------------------------
!
!==============================================================
! DIALOGUE AVEC UN ECRAN
!==============================================================
!
ENTRY DIAECR ( LIBL,RETKEY,CODCHP,IND,* )
!----------------------------------------
!
LASTKEY = -1
IF ( CODCHP .NE. 0 ) THEN
CALL FDV$PUTL ( LIBL )
IF (FMS_STATUS .NE. FDV$_SUC) RETURN 1
CALL FDV$GETAL (,RETKEY,NOMS(CODCHP),IND )
ELSE
CALL FDV$GETAL (,RETKEY )
ENDIF
IF (LASTKEY .GE. 0) THEN
RETKEY = LASTKEY
LASTKEY = -1
ENDIF
IF (FMS_STATUS .NE. FDV$_SUC) RETURN 1
!
!..fin..
!
RETURN
!
!
C----------------------------------------------------------------------
!
!==============================================================
! DIALOGUE AVEC UN ECRAN, AFFICHAGE D'UN MESSAGE
!==============================================================
!
ENTRY MSGECR ( LIBL,FLGWAIT,* )
!----------------------
!
CALL FDV$PUTL ( LIBL )
IF (FMS_STATUS .NE. FDV$_SUC) RETURN 1
!
IF ( FLGWAIT ) CALL FDV$WAIT
!
!..fin..
!
RETURN
!
!
!==============================================================
! VALEUR TEXTUELLE DU CHAMP DESIGNE PAR POSCUR, INDCUR
!==============================================================
!
ENTRY VALCHP( CODCHP, IND, VALCUR )
!
! Restauration du contexte
!
CALL TGETTAB( VALS, SVALS)
CALL NGETTAB( INDS, SINDS)
CALL NGETTAB( SIZS, SSIZS)
!
I = CODCHP
IF (INDS( CODCHP).NE.0) THEN
I = CODCHP + IND - 1
ENDIF
!
IF ( INDS( I) .EQ. 0) THEN
IND_DEB = 1
IND_FIN = SIZS( I)
ELSE
IND_DEB = ( ( I - CODCHP) * SIZS( I)) + 1
IND_FIN = IND_DEB + SIZS( I) - 1
END IF
!
IF (INDS( POSCUR) .NE. 0) THEN
CODCHP = CODCHP + IND
END IF
VALCUR = VALS( CODCHP)( IND_DEB:IND_FIN)
!
RETURN
!
!==============================================================
! VALEUR NUMERIQUE DU CHAMP DESIGNE PAR POSCUR, INDCUR
!==============================================================
!
ENTRY NUMCHP( CODCHP, IND, NUMCUR)
!
CALL NGETTAB( NUMS, SNUMS)
CALL NGETTAB( INDS, SINDS)
CALL NGETTAB( SIZS, SSIZS)
!
I = CODCHP
IF (INDS( CODCHP).NE.0) THEN
I = CODCHP + IND - 1
ENDIF
!
NUMCUR = NUMS( I)
!
RETURN
!
!
!==============================================================
! REINITIALISATION DES VALEURS D'UN ECRAN
!==============================================================
!
ENTRY RSTECR
!
!CALL TGETTAB( VALS, SVALS)
!CALL TGETTAB( SAVS, SSAVS)
!CALL NGETTAB( NUMS, SNUMS)
!CALL NGETTAB( RELS, SRELS)
!CALL NGETTAB( INDS, SINDS)
!CALL NGETTAB( SIZS, SSIZS)
!
FLGINIT = .TRUE.
!
DO I = 1, NBZON
IF ( INDS( I) .EQ. 0) THEN
IND_DEB = 1
IND_FIN = SIZS( I)
POSCUR = I
ELSE
IF ( INDS( I) .EQ. 1) THEN
POSCUR = I
END IF
IND_DEB = ( ( I - POSCUR) * SIZS( I)) + 1
IND_FIN = IND_DEB + SIZS( I) - 1
END IF
VALS( POSCUR)( IND_DEB:IND_FIN) = ' '
SAVS( POSCUR)( IND_DEB:IND_FIN) = ' '
NUMS( I) = 0
RELS( I) = 0
END DO
!
RETURN
!
C----------------------------------------------------------------------
!
!==============================================================
! DIALOGUE AVEC UN ECRAN,
!==============================================================
!
ENTRY WAITECR ( RETKEY )
!----------------------
!
!
LASTKEY = -1
CALL FDV$WAIT ( RETKEY )
IF (LASTKEY .GE. 0) THEN
RETKEY = LASTKEY
LASTKEY = -1
ENDIF
!
!..fin..
!
RETURN
!
!
C--------.Fin.---------------------------------------------------------
!
END
!
!
!------------------------------
!..Sauvegarde du descripteur
! d'un tableau de type texte
!------------------------------
!
SUBROUTINE TSAVTAB ( TTAB , STTAB )
INTEGER TTAB(2)
INTEGER STTAB(2)
!
STTAB(1) = TTAB(1)
STTAB(2) = TTAB(2)
!
END
!
!------------------------------
!..Sauvegarde de l'adresse d'un
! tableau de type numerique
!------------------------------
!
SUBROUTINE NSAVTAB ( NTAB , SNTAB )
INTEGER NTAB
INTEGER SNTAB
!
SNTAB = %LOC(NTAB)
!
END
C---------------------------------------
!
!------------------------------
!..Restore du descripteur
! d'un tableau de type texte
!------------------------------
!
SUBROUTINE NGETTAB ( NTAB , SNTAB )
INTEGER NTAB
INTEGER SNTAB
!
C NTAB = SNTAB
!
END
!
!------------------------------
!..Restore du descripteur
! d'un tableau de type numerique
!------------------------------
!
SUBROUTINE TGETTAB ( TTAB , STTAB )
INTEGER TTAB(2)
INTEGER STTAB(2)
!
TTAB(1) = STTAB(1)
TTAB(2) = STTAB(2)
!
END
| T.R | Title | User | Personal
Name | Date | Lines |
|---|
| 1210.1 | Invalid program | QUARK::LIONEL | Free advice is worth every cent | Wed Mar 05 1997 09:53 | 52 |
| The problem is that the program is illegal Fortran, but the VAX compiler doesn't
detect this and it just "happens" to work.
The first error encountered (first two error messages) are in regards to the
following section of code:
ENTRY RSTECR
!
!CALL TGETTAB( VALS, SVALS)
!CALL TGETTAB( SAVS, SSAVS)
!CALL NGETTAB( NUMS, SNUMS)
!CALL NGETTAB( RELS, SRELS)
!CALL NGETTAB( INDS, SINDS)
!CALL NGETTAB( SIZS, SSIZS)
!
FLGINIT = .TRUE.
!
DO I = 1, NBZON
IF ( INDS( I) .EQ. 0) THEN
IND_DEB = 1
IND_FIN = SIZS( I)
POSCUR = I
ELSE
IF ( INDS( I) .EQ. 1) THEN
POSCUR = I
END IF
IND_DEB = ( ( I - POSCUR) * SIZS( I)) + 1
IND_FIN = IND_DEB + SIZS( I) - 1
END IF
VALS( POSCUR)( IND_DEB:IND_FIN) = ' '
SAVS( POSCUR)( IND_DEB:IND_FIN) = ' '
NUMS( I) = 0
RELS( I) = 0
END DO
!
RETURN
The compiler is complaining that VALS (and later SAVS) are not dummy arguments
to ENTRY point RSTECR and that there is no path to the statements using them
from any entry point which DOES include these in its argument list. You are
not allowed to use a dummy argument unless it was present in the argument list
of the entry point through which you entered. It works on VAX as a side-effect
of the way that the VAX compiler implements entry points, but it is not
supported (and indeed the VAX documentation explicitly says you can't do this.)
The VAX compiler's analysis isn't as sophisticated as the Alpha compiler's,
so it can't figure this out.
All of the other error messages are due to the same sort of coding error.
A possible workaround is to put these variables in COMMON, but I don't know
how this fits in with the larger application.
Steve
|
| 1210.2 | | PRSSOS::MAILLARD | Denis MAILLARD | Wed Mar 05 1997 10:09 | 4 |
| Re .1: Thanks a lot, Steve. I unfortunately do not know enough Fortran
to understand clearly the meaning of the messages, but now I know how
to handle this.
Denis.
|
| 1210.3 | | QUARK::LIONEL | Free advice is worth every cent | Wed Mar 05 1997 11:12 | 3 |
| That's what we're here for.
Steve
|
| 1210.4 | | TLE::EKLUND | Always smiling on the inside! | Wed Mar 05 1997 13:06 | 27 |
| Actually there are other problems as well, some of which
may not have easy solutions. Steve is correct in what he
offers, but the dummy arguments are declared character*(*),
which is the most difficult case to handle. Steve's
suggestion of putting the variables in COMMON is a very good
one, if possible. The other obvious problem is that there
are actual arguments with different types than their
corresponding formal arguments. In particular, you might
look at TGETTAB is called (character argument!?). Using
/warn=argument may help to identify some of the problems.
You will find, for example, that a pointer on AVMS is an
integer*8 variable instead of integer*4 on VAX.
I'm afraid that this program is due for some major
changes. It was depending upon arguments being "preserved"
across calls to a routine (and its ENTRY points), and this
simply does NOT happen.
Cheers!
Dave Eklund
PS Feel free to ask more questions. Because of how the
program is written, we suspect it will NOT be easy to fix
the problems we mentioned.
Dave E
|