Initial commit from Polytechnique Montreal

1 files changed, 420 insertions, 0 deletions

diff --git a/Dragon/src/VDG.f b/Dragon/src/VDG.f
new file mode 100644
index 0000000..d00f17a
--- /dev/null
+++ b/Dragon/src/VDG.f
@@ -0,0 +1,420 @@
+*DECK VDG
+      SUBROUTINE VDG(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY)
+*
+*-----------------------------------------------------------------------
+*
+* Reaction rate comparison operator for Van Der Gucht benchmarks.
+*
+*Copyright:
+* Copyright (C) 2002 Ecole Polytechnique de Montreal
+* This library is free software; you can redistribute it and/or
+* modify it under the terms of the GNU Lesser General Public
+* License as published by the Free Software Foundation; either
+* version 2.1 of the License, or (at your option) any later version
+*
+*Author(s): A. Hebert
+*
+*Parameters: input/output
+* NENTRY  number of LCM objects or files used by the operator.
+* HENTRY  name of each LCM object or file:
+*         HENTRY(1): read-only reference type(L_EDIT);
+*         HENTRY(2): read-only type(L_EDIT).
+* IENTRY  type of each LCM object or file:
+*         =1 LCM memory object; =2 XSM file; =3 sequential binary file;
+*         =4 sequential ascii file.
+* JENTRY  access of each LCM object or file:
+*         =0 the LCM object or file is created;
+*         =1 the LCM object or file is open for modifications;
+*         =2 the LCM object or file is open in read-only mode.
+* KENTRY  LCM object address or file unit number.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      INTEGER      NENTRY,IENTRY(NENTRY),JENTRY(NENTRY)
+      TYPE(C_PTR)  KENTRY(NENTRY)
+      CHARACTER    HENTRY(NENTRY)*12
+*----
+*  LOCAL VARIABLES
+*----
+      PARAMETER (MAXGRO=500,MAXISO=100)
+      CHARACTER TEXT4*4,TITLE*72,TEXT12*12,HSIGN*12,HSMG*131
+      DOUBLE PRECISION DFLOTT
+      TYPE(C_PTR) IPLIB,JPLIB,IPEDI,JPEDI
+*----
+*  ALLOCATABLE ARRAYS
+*----
+      REAL, ALLOCATABLE, DIMENSION(:) :: SIGA2,DELTA2,SIGA1,ERR,FLUX,
+     1 SIGS,SIGA,DEN2,VOLU2,DEN1,VOLU1,SIGA3,SIGA4,DELTA1
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: SIGA3I,SIGA4I
+      CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: NAMES1,NAMES2
+      TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO1,IPISO2
+*----
+*  SCRATCH STORAGE ALLOCATION
+*----
+      ALLOCATE(DELTA2(MAXGRO),ERR(MAXGRO),NAMES2(MAXISO),FLUX(MAXGRO),
+     1 SIGS(MAXGRO),SIGA(MAXGRO),DEN2(MAXISO),VOLU2(MAXISO),
+     2 DEN1(MAXISO),VOLU1(MAXISO),NAMES1(MAXISO),DELTA1(MAXGRO))
+*----
+*  PARAMETER VALIDATION.
+*----
+      IF(NENTRY.LE.1) CALL XABORT('VDG: TWO PARAMETERS EXPECTED.')
+      IF((JENTRY(1).NE.2).OR.(IENTRY(1).LT.1).OR.(IENTRY(1).GT.4))
+     1 CALL XABORT('VDG: LINKED LIST OR FILE IN READ-ONLY MODE EXPEC'
+     2 //'TED AT FIRST RHS.')
+      IF((JENTRY(2).NE.2).OR.(IENTRY(2).LT.1).OR.(IENTRY(2).GT.4))
+     1 CALL XABORT('VDG: LINKED LIST OR FILE IN READ-ONLY MODE EXPEC'
+     2 //'TED AT SECOND RHS.')
+*----
+*  READ INPUT DATA.
+*----
+      IMPX=1
+      IG1=1
+      IG2=9999999
+      IPICK=0
+   10 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT)
+      IF(INDIC.EQ.10) GO TO 20
+      IF(INDIC.NE.3) CALL XABORT('VDG: CHARACTER DATA EXPECTED(1).')
+      IF(TEXT4.EQ.'EDIT') THEN
+         CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT)
+         IF(INDIC.NE.1) CALL XABORT('VDG: INTEGER DATA EXPECTED(1).')
+      ELSE IF(TEXT4.EQ.'GRMI') THEN
+         CALL REDGET(INDIC,IG1,FLOTT,TEXT4,DFLOTT)
+         IF(INDIC.NE.1) CALL XABORT('VDG: INTEGER DATA EXPECTED(3).')
+      ELSE IF(TEXT4.EQ.'GRMA') THEN
+         CALL REDGET(INDIC,IG2,FLOTT,TEXT4,DFLOTT)
+         IF(INDIC.NE.1) CALL XABORT('VDG: INTEGER DATA EXPECTED(4).')
+      ELSE IF(TEXT4.EQ.';') THEN
+         GO TO 20
+      ELSE IF(TEXT4.EQ.'PICK') THEN
+         IPICK=1
+         GO TO 20
+      ELSE
+         CALL XABORT('VDG: '//TEXT4//' IS AN INVALID KEY WORD.')
+      ENDIF
+      GO TO 10
+*----
+*  PROCESS FIRST AND SECOND RHS.
+*----
+   20 IF(IENTRY(1).GE.3) THEN
+         CALL LCMOP(IPLIB,'COPY1',0,1,0)
+         IFILE=FILUNIT(KENTRY(1))
+         CALL LCMEXP(IPLIB,0,IFILE,IENTRY(1)-2,2)
+      ELSE
+         IPLIB=KENTRY(1)
+      ENDIF
+      CALL LCMGTC(IPLIB,'SIGNATURE',12,HSIGN)
+      IF(HSIGN.NE.'L_EDIT') THEN
+         TEXT12=HENTRY(1)
+         CALL XABORT('VDG: SIGNATURE OF '//TEXT12//' IS '//HSIGN//
+     1   '. L_EDIT EXPECTED.')
+      ENDIF
+      IF(IENTRY(2).GE.3) THEN
+         CALL LCMOP(IPEDI,'COPY2',0,1,0)
+         IFILE=FILUNIT(KENTRY(2))
+         CALL LCMEXP(IPEDI,0,IFILE,IENTRY(2)-2,2)
+      ELSE
+         IPEDI=KENTRY(2)
+      ENDIF
+      CALL LCMGTC(IPEDI,'SIGNATURE',12,HSIGN)
+      IF(HSIGN.NE.'L_EDIT') THEN
+         TEXT12=HENTRY(2)
+         CALL XABORT('VDG: SIGNATURE OF '//TEXT12//' IS '//HSIGN//
+     1   '. L_EDIT EXPECTED.')
+      ENDIF
+      CALL LCMLEN(IPEDI,'TITLE',LENGT,ITYLCM)
+      IF(LENGT.GT.0) THEN
+         CALL LCMGTC(IPEDI,'TITLE',72,TITLE)
+      ELSE
+         TITLE='*** NO TITLE PROVIDED ***'
+      ENDIF
+      WRITE(6,'(/1X,A72)') TITLE
+*----
+*  RECOVER GENERAL INFORMATION FROM THE APPROXIMATE RUN.
+*----
+      CALL LCMSIX(IPEDI,'REF-CASE0001',1)
+      CALL LCMLEN(IPEDI,'ISOTOPESDENS',NISOT1,ITYLCM)
+      WRITE(6,*) 'VDG: DRAGON NISOT(APPROX)=',NISOT1
+      IF(NISOT1.GT.MAXISO) CALL XABORT('VDG: INSUFFICIENT MAXISO(1).')
+      CALL LCMGTC(IPEDI,'ISOTOPESUSED',12,NISOT1,NAMES1)
+      IF(IMPX.GT.1)  THEN
+        WRITE(6,'(/24H VDG: APPROXIMATE OUTPUT)')
+        CALL LCMLIB(IPEDI)
+        WRITE(6,'(9H ISOTOPES/(2H '',A12,1H'',:,2X,1H'',A12,1H'',:,2X,
+     1  1H'',A12,1H'',:,2X,1H'',A12,1H''))') NAMES1(:NISOT1)
+      ENDIF
+      CALL LCMLEN(IPEDI,'DELTAU',LGRP1,ITYLCM)
+      IF(LGRP1.GT.MAXGRO) CALL XABORT('VDG: INSUFFICIENT MAXGRO(1).')
+      CALL LCMGET(IPEDI,'DELTAU',DELTA1)
+      CALL LCMGET(IPEDI,'ISOTOPESVOL',VOLU1)
+      CALL LCMGET(IPEDI,'ISOTOPESDENS',DEN1)
+*----
+*  SET THE LCM MICROLIB ISOTOPEWISE DIRECTORIES.
+*----
+      ALLOCATE(IPISO1(NISOT1))
+      CALL LIBIPS(IPEDI,NISOT1,IPISO1)
+*----
+*  RECOVER GENERAL INFORMATION FROM THE AUTOSECOL RUN.
+*----
+      CALL LCMSIX(IPLIB,'REF-CASE0001',1)
+      CALL LCMLEN(IPLIB,'ISOTOPESDENS',NISOT2,ITYLCM)
+      IF(NISOT2.NE.NISOT1) CALL XABORT('VDG: INVALIB NISOT.')
+      WRITE(6,*) 'VDG: DRAGON NISOT(APPROX)=',NISOT2
+      CALL LCMGTC(IPLIB,'ISOTOPESUSED',12,NISOT2,NAMES2)
+      IF(IMPX.GT.1)  THEN
+        WRITE(6,'(/22H VDG: AUTOSECOL OUTPUT)')
+        CALL LCMLIB(IPLIB)
+        WRITE(6,'(9H ISOTOPES/(2H '',A12,1H'',:,2X,1H'',A12,1H'',:,2X,
+     1  1H'',A12,1H'',:,2X,1H'',A12,1H''))') NAMES2(:NISOT2)
+      ENDIF
+      CALL LCMLEN(IPLIB,'DELTAU',LGRP2,ITYLCM)
+      IF(LGRP2.GT.MAXGRO) CALL XABORT('VDG: INSUFFICIENT MAXGRO(2).')
+      CALL LCMGET(IPLIB,'DELTAU',DELTA2)
+      LGRMIN=LGRP2+1
+      LGRMAX=0
+      IG2=MIN(LGRP2,IG2)
+      DO 30 I=IG1,IG2
+      IF(DELTA2(I).NE.0.0) THEN
+         LGRMIN=MIN(LGRMIN,I)
+         LGRMAX=MAX(LGRMAX,I)
+      ENDIF
+   30 CONTINUE
+      CALL LCMGET(IPLIB,'ISOTOPESVOL',VOLU2)
+      CALL LCMGET(IPLIB,'ISOTOPESDENS',DEN2)
+*----
+*  SET THE LCM MICROLIB ISOTOPEWISE DIRECTORIES.
+*----
+      ALLOCATE(IPISO2(NISOT2))
+      CALL LIBIPS(IPLIB,NISOT2,IPISO2)
+*----
+*  LOOP OVER THE ISOTOPES OF THE APPROXIMATE RUN.
+*----
+      ALLOCATE(SIGA1(LGRP1),SIGA2(LGRP2),SIGA3(LGRP1),SIGA4(LGRP2))
+      ALLOCATE(SIGA3I(LGRP1,NISOT1),SIGA4I(LGRP2,NISOT2))
+      SIGA3(:LGRP1)=0.0
+      SIGA4(:LGRP2)=0.0
+      SIGA3I(:LGRP1,:NISOT1)=0.0
+      SIGA4I(:LGRP2,:NISOT2)=0.0
+      NRES=0
+      DO 170 ISOT=1,NISOT1
+      TEXT12=NAMES1(ISOT)
+      IF(TEXT12(:8).EQ.'*MAC*RES') THEN
+        NRES=NRES+1
+        GO TO 170
+      ENDIF
+      SIGA1(:LGRP1)=0.0
+      SIGA2(:LGRP2)=0.0
+      NAMES1(ISOT)=TEXT12
+      WRITE(6,'(/26H VDG: PROCESSING ISOTOPE '',A12,2H''.)') TEXT12
+      IF(NAMES1(ISOT).NE.NAMES2(ISOT)) THEN
+        WRITE(HSMG,'(28H VDG: INVALID ISOTOPE NAMES=,A12,4H VS ,A12,
+     1  1H.)') NAMES1(ISOT),NAMES2(ISOT)
+        CALL XABORT(HSMG)
+      ENDIF
+      JPEDI=IPISO1(ISOT)
+      IF(.NOT.C_ASSOCIATED(JPEDI)) CALL XABORT('VDG: ERROR NB 210')
+      CALL LCMGET(JPEDI,'NTOT0',SIGA)
+      CALL LCMGET(JPEDI,'SIGS00',SIGS)
+      CALL LCMGET(JPEDI,'NWT0',FLUX)
+      DO 100 I=1,LGRP1
+      SIGGG=(SIGA(I)-SIGS(I))*FLUX(I)*VOLU1(ISOT)*DEN1(ISOT)
+      SIGA1(I)=SIGA1(I)+SIGGG
+      SIGA3(I)=SIGA3(I)+SIGGG
+      SIGA3I(I,ISOT)=SIGA3I(I,ISOT)+SIGGG
+  100 CONTINUE
+      IF(IMPX.NE.0) THEN
+         WRITE (6,'(/27H DRAGON VOLUME OF THE FUEL=,1P,E12.4)')
+     1   VOLU1(ISOT)
+         WRITE (6,'(/27H CONDENSED LETHARGY WIDTHS:/(1X,1P,10E12.4))')
+     1   (DELTA1(I),I=1,LGRP2)
+         WRITE (6,'(/23H CONDENSED DRAGON FLUX:/(1X,1P,10E12.4))')
+     1   (FLUX(I),I=1,LGRP2)
+         WRITE (6,'(/35H CONDENSED DRAGON ABSORPTION RATES:/
+     1   (1X,1P,10E12.4))') (SIGA1(I),I=1,LGRP2)
+      ENDIF
+*----
+*  RECOVER INFORMATION FROM AUTOSECOL RUN.
+*----
+      IF(IMPX.NE.0) THEN
+         WRITE (6,'(/35H AUTOSECOL VOLUME OF THE FUEL ISOT=,I4,1H=,1P,
+     1   E12.4)') ISOT,VOLU2(ISOT)
+      ENDIF
+      JPLIB=IPISO2(ISOT)
+      IF(.NOT.C_ASSOCIATED(JPLIB)) CALL XABORT('VDG: ERROR NB 211')
+      CALL LCMGET(JPLIB,'NTOT0',SIGA)
+      CALL LCMGET(JPLIB,'SIGS00',SIGS)
+      CALL LCMGET(JPLIB,'NWT0',FLUX)
+      CALL LCMSIX(JPLIB,' ',2)
+      DO 130 I=LGRMIN,LGRMAX
+      SIGGG=(SIGA(I)-SIGS(I))*FLUX(I)*VOLU2(ISOT)*DEN2(ISOT)
+      SIGA2(I)=SIGA2(I)+SIGGG
+      SIGA4(I)=SIGA4(I)+SIGGG
+      SIGA4I(I,ISOT)=SIGA4I(I,ISOT)+SIGGG
+  130 CONTINUE
+      IF(ABS(VOLU1(ISOT)-VOLU2(ISOT)).GT.1.0E-4*VOLU1(ISOT)) THEN
+        WRITE(HSMG,'(46HVDG: INVALID INTEGRATED VOLUME IN DRAGON. ISOT,
+     1  5HOPE='',A12,16H'' DRAGON VOLUME=,1P,E12.4,16H. AUTOSECOL VOLU,
+     2  3HME=,E12.4,1H.)') NAMES1(ISOT),VOLU1(ISOT),VOLU2(ISOT)
+        CALL XABORT(HSMG)
+      ENDIF
+      IF(IMPX.NE.0) THEN
+         WRITE (6,'(/30H AUTOSECOL VOLUME OF THE FUEL=,1P,E12.4)')
+     1   VOLU2(ISOT)
+         WRITE (6,'(/23H ENERGY DOMAIN INDICES=,I5,5H --->,I5)')
+     1   LGRMIN,LGRMAX
+         WRITE (6,'(/27H CONDENSED LETHARGY WIDTHS:/(1X,1P,10E12.4))')
+     1   (DELTA2(I),I=LGRMIN,LGRMAX)
+         WRITE (6,'(/26H CONDENSED AUTOSECOL FLUX:/(1X,1P,10E12.4))')
+     1   (FLUX(I),I=LGRMIN,LGRMAX)
+         WRITE (6,'(/38H CONDENSED AUTOSECOL ABSORPTION RATES:/
+     1   (1X,1P,10E12.4))') (SIGA2(I),I=LGRMIN,LGRMAX)
+      ENDIF
+*----
+*  PERFORM STATISTICS ON A PARTICULAR ISOTOPE.
+*----
+      SUMREF=0.0
+      ZMAX=0.0
+      ZAVER=0.0
+      SUM=0.0
+      IMAX=0
+      DO 150 I=LGRMIN,LGRMAX
+      ERR(I)=100.0*(SIGA1(I)-SIGA2(I))/SIGA2(I)
+      IF(I-LGRMIN+1.GE.3) ZAVER=ZAVER+ABS(ERR(I))
+      EPSD=ABS(DELTA2(I)-DELTA1(I))/DELTA2(I)
+      IF(EPSD.GT.1.0E-3) CALL XABORT('VDG: INVALID DELTA1.(1)')
+      IF((I-LGRMIN+1.GE.3).AND.(ABS(ERR(I)).GT.ZMAX)) THEN
+         ZMAX=ABS(ERR(I))
+         IMAX=I
+      ENDIF
+      SUMREF=SUMREF+SIGA2(I)
+      SUM=SUM+SIGA1(I)
+  150 CONTINUE
+      ZAVER=ZAVER/REAL(LGRP2-2)
+      SUMERR=100.0*(SUM-SUMREF)/SUMREF
+      WRITE (6,'(1H1/11H ISOTOPE ='',A12,1H''//10X,9HAUTOSECOL,3X,
+     1 6HDRAGON,8X,5HERROR)') NAMES1(ISOT)
+      DO 160 I=LGRMIN,LGRMAX
+      WRITE (6,'(1X,I5,3X,1P,2E12.5,0P,F9.3,2H %)') I,SIGA2(I),
+     1 SIGA1(I),ERR(I)
+  160 CONTINUE
+      WRITE (6,'(10X,11(1H-),1X,11(1H-)/3X,3HSUM,3X,1P,2E12.5,0P,F9.3,
+     1 2H %)') SUMREF,SUM,SUMERR
+      WRITE (6,'(/10X,14HMAXIMUM ERROR=,F9.3,2H %,9H IN GROUP,I4)')
+     1 ZMAX,IMAX
+      WRITE (6,'(10X,14HAVERAGE ERROR=,F9.3,2H %)') ZAVER
+      WRITE (6,'(7X,17HINTEGRATED ERROR=,F9.3,2H %/)') SUMERR
+  170 CONTINUE
+      DEALLOCATE(IPISO2,IPISO1)
+*----
+*  PERFORM STATISTICS ON EACH TYPE OF ISOTOPE.
+*----
+      IF(NISOT1-NRES.GT.2) THEN
+         DO 200 ISOT=1,NISOT1
+         IF(NAMES1(ISOT)(:8).EQ.'*MAC*RES') GO TO 200
+         SUMREF=0.0
+         ZMAX=0.0
+         ZAVER=0.0
+         SUM=0.0
+         IMAX=0
+         DO 180 I=LGRMIN,LGRMAX
+         ERR(I)=100.0*(SIGA3I(I,ISOT)-SIGA4I(I,ISOT))/SIGA4I(I,ISOT)
+         IF(I-LGRMIN+1.GE.3) ZAVER=ZAVER+ABS(ERR(I))
+         EPSD=ABS(DELTA2(I)-DELTA1(I))/DELTA2(I)
+         IF(EPSD.GT.1.0E-3) CALL XABORT('VDG: INVALID DELTA1.(2)')
+         IF((I-LGRMIN+1.GE.3).AND.(ABS(ERR(I)).GT.ZMAX)) THEN
+            ZMAX=ABS(ERR(I))
+            IMAX=I
+         ENDIF
+         SUMREF=SUMREF+SIGA4I(I,ISOT)
+         SUM=SUM+SIGA3I(I,ISOT)
+  180    CONTINUE
+         ZAVER=ZAVER/REAL(LGRMAX-LGRMIN-1)
+         SUMERR=100.0*(SUM-SUMREF)/SUMREF
+         WRITE (6,'(1H1/12H SUM OF ALL ,A8//10X,9HAUTOSECOL,3X,
+     1   6HDRAGON,8X,5HERROR)') NAMES1(ISOT)
+         DO 190 I=LGRMIN,LGRMAX
+         WRITE (6,'(1X,I5,3X,1P,2E12.5,0P,F9.3,2H %)') I,SIGA4I(I,ISOT),
+     1   SIGA3I(I,ISOT),ERR(I)
+  190    CONTINUE
+         WRITE (6,'(10X,11(1H-),1X,11(1H-)/3X,3HSUM,3X,1P,2E12.5,0P,
+     1   F9.3,2H %)') SUMREF,SUM,SUMERR
+         WRITE (6,'(/10X,14HMAXIMUM ERROR=,F9.3,2H %,9H IN GROUP,I4)')
+     1   ZMAX,IMAX
+         WRITE (6,'(10X,14HAVERAGE ERROR=,F9.3,2H %)') ZAVER
+         WRITE (6,'(7X,17HINTEGRATED ERROR=,F9.3,2H %/)') SUMERR
+  200    CONTINUE
+      ENDIF
+*----
+*  PERFORM STATISTICS ON ALL ISOTOPES.
+*----
+      SUMREF=0.0
+      ZMAX=0.0
+      ZAVER=0.0
+      SUM=0.0
+      IMAX=0
+      DO 210 I=LGRMIN,LGRMAX
+      ERR(I)=100.0*(SIGA3(I)-SIGA4(I))/SIGA4(I)
+      IF(I-LGRMIN+1.GE.3) ZAVER=ZAVER+ABS(ERR(I))
+      EPSD=ABS(DELTA2(I)-DELTA1(I))/DELTA2(I)
+      IF(EPSD.GT.1.0E-3) CALL XABORT('VDG: INVALID DELTA1.(3)')
+      IF((I-LGRMIN+1.GE.3).AND.(ABS(ERR(I)).GT.ZMAX)) THEN
+         ZMAX=ABS(ERR(I))
+         IMAX=I
+      ENDIF
+      SUMREF=SUMREF+SIGA4(I)
+      SUM=SUM+SIGA3(I)
+  210 CONTINUE
+      ZAVER=ZAVER/REAL(LGRMAX-LGRMIN-1)
+      SUMERR=100.0*(SUM-SUMREF)/SUMREF
+      WRITE (6,'(1H1/20H SUM OF ALL ISOTOPES//10X,9HAUTOSECOL,3X,
+     1 6HDRAGON,8X,5HERROR)')
+      DO 220 I=LGRMIN,LGRMAX
+      WRITE (6,'(1X,I5,3X,1P,2E12.5,0P,F9.3,2H %)') I,SIGA4(I),
+     1 SIGA3(I),ERR(I)
+  220 CONTINUE
+      WRITE (6,'(10X,11(1H-),1X,11(1H-)/3X,3HSUM,3X,1P,2E12.5,0P,F9.3,
+     1 2H %)') SUMREF,SUM,SUMERR
+      WRITE (6,'(/10X,14HMAXIMUM ERROR=,F9.3,2H %,9H IN GROUP,I4)')
+     1 ZMAX,IMAX
+      WRITE (6,'(10X,14HAVERAGE ERROR=,F9.3,2H %)') ZAVER
+      WRITE (6,'(7X,17HINTEGRATED ERROR=,F9.3,2H %/)') SUMERR
+      IF(IMPX.GT.50) THEN
+        WRITE(6,'(1P,E12.5,1H,,E12.5,1H,,E12.5,1H,,E12.5,1H,,E12.5,1H,,
+     1  E12.5,1H,,E12.5,1H,,E12.5,1H,,E12.5,1H,,E12.5,1H,)')
+     2  (ERR(I),I=LGRMIN,LGRMAX)
+      ENDIF
+*----
+*  RECOVER THE FINAL POWER AND SAVE IT IN A CLE-2000 VARIABLE
+*----
+      IF(IPICK.EQ.1) THEN
+        CALL REDGET(ITYP,NITMA,FLOTT,TEXT4,DFLOTT)
+        IF(INDIC.NE.3) CALL XABORT('VDG: CHARACTER DATA EXPECTED(2).')
+        IF(TEXT4.EQ.'MAXV') THEN
+          VAL=ZMAX
+        ELSE IF(TEXT4.EQ.'AVER') THEN
+          VAL=ZAVER
+        ELSE IF(TEXT4.EQ.'INTG') THEN
+          VAL=SUMERR
+        ELSE
+          CALL XABORT('VDG: MAXV/AVER/INTG KEYWORD EXPECTED.')
+        ENDIF
+        CALL REDGET(ITYP,NITMA,FLOTT,TEXT4,DFLOTT)
+        IF(ITYP.NE.-2) CALL XABORT('VDG: OUTPUT REAL EXPECTED.')
+        ITYP=2
+        CALL REDPUT(ITYP,NITMA,VAL,TEXT4,DFLOTT)
+        CALL REDGET(ITYP,NITMA,FLOTT,TEXT4,DFLOTT)
+        IF((ITYP.NE.3).OR.(TEXT4.NE.';')) THEN
+          CALL XABORT('VDG: ; CHARACTER EXPECTED.')
+        ENDIF
+      ENDIF
+*----
+*  SCRATCH STORAGE DEALLOCATION
+*----
+      DEALLOCATE(SIGA4I,SIGA3I,SIGA4,SIGA3,SIGA2,SIGA1)
+      DEALLOCATE(DELTA1,NAMES1,VOLU1,DEN1,VOLU2,DEN2,SIGA,SIGS,FLUX,
+     1 NAMES2,ERR,DELTA2)
+      RETURN
+      END