diff options
Diffstat (limited to 'Dragon/src/PSPGET.f')
| -rw-r--r-- | Dragon/src/PSPGET.f | 237 |
1 files changed, 237 insertions, 0 deletions
diff --git a/Dragon/src/PSPGET.f b/Dragon/src/PSPGET.f new file mode 100644 index 0000000..17d417e --- /dev/null +++ b/Dragon/src/PSPGET.f @@ -0,0 +1,237 @@ +*DECK PSPGET + SUBROUTINE PSPGET(IPRINT,ITYPE,ICOLR,NGROUP,NGT,ICOND) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read PSP: module input data. +* +*Copyright: +* Copyright (C) 1999 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): +* G. Marleau +* +*Parameters: input +* IPRINT print level. +* ITYPE type of graphic: +* =0 color per region number; +* =1 color per material; +* =2 color for flux (one group); +* =3 color for flux (multigroup); +* =4 color per material for homogenizatION (HMIX); +* =5 color for mode (one group); +* =6 color for mode (multigroup). +* ICOLR color set used: +* = -4 fill hsb with no-contour; +* = -3 fill cmyk with no-contour; +* = -2 fill rgb with no-contour; +* = -1 fill bw with no-contour; +* = 0 no fill contour only; +* = 1 fill bw and contour; +* = 2 fill rgb and contour; +* = 3 fill cmyk and contour; +* = 4 fill hsb and contour. +* NGROUP number of groups for flux. +* NGT number of condensed groups for flux. +* ICOND upper group condensation limit. +* +*Comments: +* Input instructions: +* [ EDIT iprint ] +* [ FILL { NONE | GRAY | RGB | CMYK | HSB } [ NOCONTOUR ] ] +* [ TYPE { REGION | MIXTURE | FLUX | HMIX | +* MGFLUX (icond(i),i=1,ngt) } ] ; +* DEFAULT: +* IPRINT = 1 -> EDIT 1 +* ITYPE = 0 -> PER REGION NUMBER +* ICOLR = 4 -> FILL HSB WITH CONTOUR +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='PSPGET') +*---- +* ROUTINE PARAMETERS +*---- + INTEGER IPRINT,ITYPE,ICOLR,NGROUP,NGT + INTEGER ICOND(NGROUP) +*---- +* REDGET INPUT VARIABLES +*---- + INTEGER ITYPLU,INTLIR + CHARACTER CARLIR*12 + REAL REALIR + DOUBLE PRECISION DBLLIR +*---- +* LOCAL PARAMETERS +*---- + INTEGER ICOL,ITY,ICONT,IGT +*---- +* READ OPTIONS +*---- + IPRINT=1 + ICOL=4 + ITY=0 + ICONT=1 + 100 CONTINUE + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + 101 CONTINUE + IF(ITYPLU .EQ. 10) THEN + GO TO 105 + ELSE IF(ITYPLU .NE. 3) THEN + CALL XABORT(NAMSBR//': ERROR -> CHARACTER VARIABLE EXPECTED') + ENDIF + IF(CARLIR(1:1) .EQ. ';' ) THEN + GO TO 105 + ELSE IF(CARLIR .EQ. 'EDIT' ) THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1 ) GO TO 101 + IPRINT=INTLIR + ELSE IF(CARLIR(1:4) .EQ. 'FILL' ) THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 3 ) GO TO 101 + IF(CARLIR .EQ. 'NONE') THEN + ICOL=0 + ELSE IF(CARLIR .EQ. 'GRAY') THEN + ICOL=1 + ELSE IF(CARLIR .EQ. 'RGB') THEN + ICOL=2 + ELSE IF(CARLIR .EQ. 'CMYK') THEN + ICOL=3 + ELSE IF(CARLIR .EQ. 'HSB') THEN + ICOL=4 + ELSE + CALL XABORT(NAMSBR//': ILEGAL FILL KEYWORD '//CARLIR// + > 'KEYWORD EXPECTED: NONE, GRAY, RGB, CMYK, HSB') + ENDIF + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 3 ) GO TO 101 + IF(CARLIR(1:4) .EQ. 'NOCO') THEN + ICONT=0 + ELSE + GO TO 101 + ENDIF + ELSE IF(CARLIR(1:4) .EQ. 'TYPE' ) THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(CARLIR(1:4) .EQ. 'REGI') THEN + ITY=0 + ELSE IF(CARLIR(1:4) .EQ. 'MIXT') THEN + ITY=1 + ELSE IF(CARLIR(1:4) .EQ. 'FLUX') THEN + ITY=2 + NGT=1 + ICOND(NGT)=NGROUP + ELSE IF(CARLIR(1:4) .EQ. 'MODE') THEN + ITY=5 + NGT=1 + ICOND(NGT)=NGROUP + ELSE IF(CARLIR(1:4) .EQ. 'MGFL') THEN + ITY=3 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) THEN + NGT=NGROUP + DO IGT=1,NGT + ICOND(IGT)=IGT + ENDDO + GO TO 101 + ENDIF + NGT=0 + DO IGT=1,NGROUP + NGT=NGT+1 + IF(INTLIR .LT. 1 .OR. INTLIR .GT. NGROUP) + >CALL XABORT(NAMSBR//': illegal group condensation number') + IF(IGT .GT. 1) THEN + IF(INTLIR .LE. ICOND(IGT-1)) + >CALL XABORT(NAMSBR//': group numbers must be increasing') + ENDIF + ICOND(IGT)=INTLIR + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1 ) THEN + IF(ICOND(IGT) .NE. NGROUP) THEN + NGT=NGT+1 + ICOND(NGT)=NGROUP + ENDIF + GO TO 101 + ENDIF + ENDDO + ELSE IF(CARLIR(1:4) .EQ. 'MGMD') THEN + ITY=6 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1) THEN + NGT=NGROUP + DO IGT=1,NGT + ICOND(IGT)=IGT + ENDDO + GO TO 101 + ENDIF + NGT=0 + DO IGT=1,NGROUP + NGT=NGT+1 + IF(INTLIR .LT. 1 .OR. INTLIR .GT. NGROUP) + >CALL XABORT(NAMSBR//': illegal group condensation number') + IF(IGT .GT. 1) THEN + IF(INTLIR .LE. ICOND(IGT-1)) + >CALL XABORT(NAMSBR//': group numbers must be increasing') + ENDIF + ICOND(IGT)=INTLIR + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU .NE. 1 ) THEN + IF(ICOND(IGT) .NE. NGROUP) THEN + NGT=NGT+1 + ICOND(NGT)=NGROUP + ENDIF + GO TO 101 + ENDIF + ENDDO + ELSE IF(CARLIR(1:4) .EQ. 'HMIX') THEN + ITY=4 + ELSE + CALL XABORT(NAMSBR//': ILEGAL TYPE KEYWORD '//CARLIR// + > 'KEYWORD EXPECTED: REGION, MIXTURE, FLUX, MGFLUX') + ENDIF + ELSE +*---- +* INVALID OPTION +*---- + CALL XABORT(NAMSBR//': ILEGAL MAIN KEYWORD '//CARLIR// + > 'KEYWORD EXPECTED: FILL, TYPE, EDIT OR ; ') + ENDIF + GO TO 100 + 105 CONTINUE +*---- +* TEST READ OPTIONS +* IF FILL = NONE (ICOL = 0) IMPOSE CONTOUR +*---- + IF(ICONT .EQ. 0) THEN + ICOLR=-ICOL + ELSE + ICOLR=ICOL + ENDIF + ITYPE=ITY +*---- +* PRINT ECHO OF PSP OPTIONS THAT WILL BE USED +*---- + IF(IPRINT .GE. 1 ) THEN + WRITE(IOUT,6000) IPRINT,ICOL,ITY,ICONT + ENDIF +*---- +* RETURN +*---- + RETURN +*---- +* FORMAT +*---- + 6000 FORMAT(' ------ PSP EXECUTION OPTIONS --------'/ + > ' PRINT LEVEL = ',I8 / + > ' COLOR = ',I8 / + > ' TYPE = ',I8 / + > ' CONTOUR = ',I8 / + > ' --------------------------------------') + END |