*DECK MRGGET SUBROUTINE MRGGET(IPRINT,NSOUTO,NVOUTO,NSOUTN,NVOUTN, > IUPD,IMERGE,MIXN,ALBEDN) * *---------- * *Purpose: * Read merge options. * *Copyright: * Copyright (C) 1997 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. * NSOUTO old number of surfaces. * NVOUTO old number of regions. * *Parameters: output * NSOUTN new number of surfaces. * NVOUTN new number of regions. * IUPD type of merge required: * IUPD(1) for region merge and track splitting; * IUPD(2) for surface merge; * IUPD(3) for material modification; * IUPD(4) for albedo modification. * IMERGE merged position. * MIXN new material for old regions. * ALBEDN new surface albedo. * *Comments: * Input options: * [ EDIT iprint ] * [ REGI (imerge(ii),ii=1,nvouto)] -> IUPD(1) > 0 * [ EXTR (imerge(ii),ii=1,-IUPD(1))] -> IUPD(1) < 0 * [ SURF (imerge(ii),ii=-1,-nsouto)] -> IUPD(2) < 0 * [ { OLDM (mixn(ii),ii=1,nvouto) | -> IUPD(3) > 0 * NEWM (mixn(ii),ii=1,nvouto) } ] -> IUPD(3) < 0 * [ ALBE (albedn(ii),ii=1,6)] -> IUPD(4) > 0 * *---------- * IMPLICIT NONE INTEGER IOUT CHARACTER NAMSBR*6 PARAMETER (IOUT=6,NAMSBR='MRGGET') *---- * ROUTINE PARAMETERS *---- INTEGER IPRINT,NSOUTO,NVOUTO,NSOUTN,NVOUTN, > IUPD(4), > IMERGE(-NSOUTO:NVOUTO), > MIXN(NVOUTO) REAL ALBEDN(6) *---- * LOCAL VARIABLES *---- INTEGER IVSN,IVSO,ITYPLU,INTLIR CHARACTER CARLIR*12 REAL REALIR DOUBLE PRECISION DBLINP *---- * INITIALIZE IMERGE *---- IUPD(:4)=0 MIXN(:NVOUTO)=0 ALBEDN(:6)=0.0 DO IVSO=-NSOUTO,NVOUTO IMERGE(IVSO)=IVSO ENDDO NSOUTN=0 NVOUTN=0 IPRINT = 1 *---- * READ OPTION NAME *---- 110 CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLINP) 111 IF(ITYPLU.NE.3) CALL XABORT(NAMSBR// > ': READ ERROR - CHARACTER VARIABLE EXPECTED') IF(CARLIR(1:1) .EQ. ';') THEN GO TO 115 ELSE IF(CARLIR .EQ. 'EDIT') THEN CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLINP) IF(ITYPLU .NE. 1) GO TO 111 IPRINT=INTLIR ELSE IF(CARLIR(1:4) .EQ. 'REGI') THEN IF(IUPD(1) .NE. 0 ) CALL XABORT(NAMSBR// > ': A single REGI or EXTR permitted') DO IVSO=1,NVOUTO CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLINP) IF(ITYPLU .NE. 1) GO TO 111 IF(INTLIR .GT. NVOUTO) CALL XABORT(NAMSBR// > ': FINAL REGION NUMBER MUST BE SMALLER '// > 'THAN NUMBER OF ORIGINAL REGIONS') IF(INTLIR .LE. 0) CALL XABORT(NAMSBR// > ': FINAL REGION NUMBER MUST LARGER THAN 0 ') IUPD(1)=IUPD(1)+1 NVOUTN=MAX(NVOUTN,INTLIR) IMERGE(IVSO)=INTLIR ENDDO ELSE IF(CARLIR(1:4) .EQ. 'EXTR') THEN IF(IUPD(1) .NE. 0 ) CALL XABORT(NAMSBR// > ': A single REGI or EXTR permitted') DO IVSO=1,NVOUTO CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLINP) IF(ITYPLU .NE. 1) GO TO 111 IF(INTLIR .GT. NVOUTO) CALL XABORT(NAMSBR// > ': FINAL REGION NUMBER MUST BE SMALLER '// > 'THAN NUMBER OF ORIGINAL REGIONS') IF(INTLIR .LE. 0) CALL XABORT(NAMSBR// > ': FINAL REGION NUMBER MUST LARGER THAN 0 ') IUPD(1)=IUPD(1)-1 NVOUTN=MAX(NVOUTN,INTLIR) IMERGE(IVSO)=INTLIR ENDDO ELSE IF(CARLIR(1:4).EQ.'SURF') THEN DO IVSO=1,NSOUTO CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLINP) IF(ITYPLU.NE.1) GO TO 111 IF(INTLIR.GT.NSOUTO) CALL XABORT(NAMSBR// > ': FINAL SURFACE NUMBER MUST BE SMALLER '// > 'THAN NUMBER OF ORIGINAL SURFACES') IF(INTLIR .LE. 0) CALL XABORT(NAMSBR// > ': FINAL SURFACE NUMBER MUST LARGER THAN 0 ') IUPD(2)=IUPD(2)-1 NSOUTN=MAX(NSOUTN,INTLIR) IMERGE(-IVSO)=-INTLIR ENDDO ELSE IF(CARLIR(1:4) .EQ. 'OLDM') THEN DO IVSO=1,NVOUTO CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLINP) IF(ITYPLU .NE. 1) GO TO 111 IF(INTLIR .LT. 0) CALL XABORT(NAMSBR// > ': FINAL MIXTURE NUMBER MUST LARGER OR EQUAL TO 0 ') IUPD(3)=IUPD(3)+1 MIXN(IVSO)=INTLIR ENDDO ELSE IF(CARLIR(1:4) .EQ. 'NEWM') THEN DO IVSO=1,NVOUTO CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLINP) IF(ITYPLU .NE. 1) GO TO 111 IF(INTLIR .LT. 0) CALL XABORT(NAMSBR// > ': FINAL MIXTURE NUMBER MUST LARGER OR EQUAL TO 0 ') IUPD(3)=IUPD(3)-1 MIXN(IVSO)=INTLIR ENDDO ELSE IF(CARLIR(1:4) .EQ. 'ALBE') THEN DO IVSO=1,6 CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLINP) IF(ITYPLU .NE. 3) GO TO 111 IF(REALIR .LT. 0.0) CALL XABORT(NAMSBR// > ': FINAL ALBEDO MUST LARGER THAN 0.0 ') IUPD(4)=IUPD(4)+1 ALBEDN(IVSO)=REALIR ENDDO ELSE CALL XABORT(NAMSBR//': LEGAL KEYWORD '//CARLIR) ENDIF GO TO 110 115 CONTINUE *---- * CHECK IF ALL THE SUCCESSIVE REGIONS CONSIDERED *---- IF(IUPD(1) .EQ. 0) THEN NVOUTN=NVOUTO ENDIF IF(IPRINT .GE. 1) THEN WRITE(IOUT,6000) NAMSBR IF(IUPD(1) .GT. 0) THEN WRITE(IOUT,6010) WRITE(IOUT,6020) (IVSO,IMERGE(IVSO),IVSO=1,IUPD(1)) ELSE IF(IUPD(1) .LT. 0) THEN WRITE(IOUT,6015) WRITE(IOUT,6025) (IMERGE(IVSO),IVSO=1,-IUPD(1)) ENDIF IF(IUPD(2) .LT. 0) THEN WRITE(IOUT,6011) WRITE(IOUT,6020) (IVSO,IMERGE(IVSO),IVSO=-1,IUPD(2),-1) ENDIF IF(IUPD(3) .LT. 0) THEN WRITE(IOUT,6012) WRITE(IOUT,6020) (IVSO,MIXN(IVSO),IVSO=1,-IUPD(3)) ELSE IF(IUPD(3) .GT. 0) THEN WRITE(IOUT,6013) WRITE(IOUT,6020) (IVSO,MIXN(IVSO),IVSO=1,IUPD(3)) ENDIF IF(IUPD(4) .GT. 0) THEN WRITE(IOUT,6014) WRITE(IOUT,6021) (IVSO,ALBEDN(IVSO),IVSO=1,6) ENDIF WRITE(IOUT,6001) ENDIF IF(IUPD(1) .GT. 0) THEN DO IVSN=1,NVOUTN DO IVSO=1,NVOUTO IF(IMERGE(IVSO) .EQ. IVSN) GO TO 205 ENDDO CALL XABORT(NAMSBR// > ': NEW REGION NUMBERS NOT SUCCESSIVE') 205 CONTINUE ENDDO ENDIF *---- * CHECK IF ALL THE SUCCESSIVE SURFACE CONSIDERED *---- IF(IUPD(2) .EQ. 0) THEN NSOUTN=NSOUTO ENDIF IF(IUPD(2) .GT. 0) THEN DO IVSN=-NSOUTN,-1 DO IVSO=-NSOUTO,-1 IF(IMERGE(IVSO) .EQ. IVSN) GO TO 215 ENDDO CALL XABORT(NAMSBR// > ': NEW SURFACE NUMBERS NOT SUCCESSIVE') 215 CONTINUE ENDDO ENDIF *---- * RETURN *---- RETURN *---- * FORMAT *---- 6000 FORMAT(' ------ OUTPUT FROM ROUTINE = ',A6) 6001 FORMAT(' --------------------------------------') 6010 FORMAT(' REGIONAL MERGE ',/ > 3(' OLD NUNBER -> NEW NUMBER ')) 6011 FORMAT(' SURFACE MERGE ',/ > 3(' OLD NUNBER -> NEW NUMBER')) 6012 FORMAT(' MIXTURE MODIFICATION ',/ > 3(' OLD REGION -> MIXTURE ')) 6013 FORMAT(' MIXTURE MODIFICATION ',/ > 3(' NEW REGION -> MIXTURE ')) 6014 FORMAT(' ALBEDO MODIFICATION ',/ > 3(' SURFACE -> ALBEDO ')) 6015 FORMAT(' REGION EXTRACTED FROM TRACK FILE ') 6020 FORMAT(3(1X,I10,4X,I10)) 6021 FORMAT(3(1X,I10,4X,F10.7)) 6025 FORMAT(6(1X,I10)) END