diff options
Diffstat (limited to 'Trivac/src/DELTA.f')
| -rwxr-xr-x | Trivac/src/DELTA.f | 177 |
1 files changed, 177 insertions, 0 deletions
diff --git a/Trivac/src/DELTA.f b/Trivac/src/DELTA.f new file mode 100755 index 0000000..0a98e7b --- /dev/null +++ b/Trivac/src/DELTA.f @@ -0,0 +1,177 @@ +*DECK DELTA + SUBROUTINE DELTA(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* calculation of direct or adjoint source components for a fixed source +* eigenvalue problem. +* +*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): create or modification type(L_SOURCE) (GPT source) +* HENTRY(2): read-only type(L_FLUX) => unperturbed solution +* HENTRY(3): read-only type(L_SYSTEM) => unperturbed matrices +* HENTRY(4): read-only type(L_SYSTEM) => perturbed matrices +* HENTRY(5): read-only type(L_TRACK) => tracking. +* 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. +* +*Comments: +* The DELTA: calling specifications are: +* GPT := DELTA: [ GPT ] FLUX0 SYST0 DSYST TRACK :: (delta\_data) ; +* where +* GPT : name of the \emph{lcm} object (type L\_GPT) containing the fixed +* source. If GPT appears on the RHS, this information is used to initialize +* the state vector. +* FLUX0 : name of the \emph{lcm} object (type L\_FLUX) containing the +* unperturbed flux. +* SYST0 : name of the \emph{lcm} object (type L\_SYSTEM) containing the +* unperturbed system matrices. +* DSYST : name of the \emph{lcm} object (type L\_SYSTEM) containing a +* perturbation to the system matrices. +* TRACK : name of the \emph{lcm} object (type L\_TRACK) containing the +* \emph{tracking}. +* delta\_data}] : structure containing the data to module DELTA:} +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 + TYPE(C_PTR) KENTRY(NENTRY) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + CHARACTER TEXT12*12,HSIGN*12,CMODUL*12 + LOGICAL REC + INTEGER ISTATE(NSTATE) + TYPE(C_PTR) IPGPT,IPFLU0,IPSYS0,IPSYSP,IPTRK +*---- +* PARAMETER VALIDATION. +*---- + IF(NENTRY.LE.4) CALL XABORT('DELTA: FIVE PARAMETERS EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('DELTA: LC' + 1 //'M OBJECT EXPECTED AT LHS.') + IF((JENTRY(1).NE.0).AND.(JENTRY(1).NE.1)) CALL XABORT('DELTA: EN' + 1 //'TRY IN CREATE OR MODIFICATION MODE EXPECTED.') + IF((JENTRY(2).NE.2).OR.((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2))) + 1 CALL XABORT('DELTA: LCM OBJECT IN READ-ONLY MODE EXPECTED AT FI' + 2 //'RST RHS.') + IF((JENTRY(3).NE.2).OR.((IENTRY(3).NE.1).AND.(IENTRY(3).NE.2))) + 1 CALL XABORT('DELTA: LCM OBJECT IN READ-ONLY MODE EXPECTED AT SE' + 2 //'COND RHS.') + IF((JENTRY(4).NE.2).OR.((IENTRY(4).NE.1).AND.(IENTRY(4).NE.2))) + 1 CALL XABORT('DELTA: LCM OBJECT IN READ-ONLY MODE EXPECTED AT TH' + 2 //'IRD RHS.') + IF((JENTRY(5).NE.2).OR.((IENTRY(5).NE.1).AND.(IENTRY(5).NE.2))) + 1 CALL XABORT('DELTA: LCM OBJECT IN READ-ONLY MODE EXPECTED AT FO' + 2 //'URTH RHS.') + REC=(JENTRY(1).EQ.1) + IF(REC) THEN + CALL LCMGTC(KENTRY(1),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_SOURCE') THEN + TEXT12=HENTRY(1) + CALL XABORT('DELTA: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_SOURCE EXPECTED.') + ENDIF + ELSE + HSIGN='L_SOURCE' + CALL LCMPTC(KENTRY(1),'SIGNATURE',12,HSIGN) + ENDIF + CALL LCMGTC(KENTRY(2),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_FLUX') THEN + TEXT12=HENTRY(2) + CALL XABORT('DELTA: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_FLUX EXPECTED.') + ENDIF + CALL LCMGTC(KENTRY(3),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_SYSTEM') THEN + TEXT12=HENTRY(3) + CALL XABORT('DELTA: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_SYSTEM EXPECTED.') + ENDIF + CALL LCMGTC(KENTRY(4),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_SYSTEM') THEN + TEXT12=HENTRY(4) + CALL XABORT('DELTA: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_SYSTEM EXPECTED.') + ENDIF + CALL LCMGTC(KENTRY(5),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_TRACK') THEN + TEXT12=HENTRY(5) + CALL XABORT('DELTA: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_TRACK EXPECTED.') + ENDIF + CALL LCMGTC(KENTRY(2),'LINK.SYSTEM',12,TEXT12) + IF(TEXT12.NE.HENTRY(3)) CALL XABORT('DELTA: OBJECT '//HENTRY(3)// + 1 ' IS NOT AN UNPERTURBED SYSTEM OBJECT.') + CALL LCMGTC(KENTRY(2),'LINK.TRACK',12,TEXT12) + IF(TEXT12.NE.HENTRY(5)) CALL XABORT('DELTA: OBJECT '//HENTRY(3)// + 1 ' IS NOT A TRACKING OBJECT.') + TEXT12=HENTRY(2) + CALL LCMPTC(KENTRY(1),'LINK.FLUX',12,TEXT12) + TEXT12=HENTRY(3) + CALL LCMPTC(KENTRY(1),'LINK.SYSTEM',12,TEXT12) + TEXT12=HENTRY(4) + CALL LCMPTC(KENTRY(1),'LINK.TRACK',12,TEXT12) + IPGPT=KENTRY(1) + IPFLU0=KENTRY(2) + IPSYS0=KENTRY(3) + IPSYSP=KENTRY(4) + IPTRK=KENTRY(5) +*---- +* RECOVER GENERAL TRACKING INFORMATION. +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + NUN=ISTATE(2) + CALL LCMGTC(IPTRK,'TRACK-TYPE',12,CMODUL) + IF(CMODUL.NE.'TRIVAC') CALL XABORT('DELTA: TRIVAC TRACKING EXPEC' + 1 //'TED.') + CALL LCMGET(IPSYS0,'STATE-VECTOR',ISTATE) + NGRP=ISTATE(1) + LL4=ISTATE(2) + CALL LCMGET(IPSYSP,'STATE-VECTOR',ISTATE) + IF(ISTATE(1).NE.NGRP) CALL XABORT('DELTA: INVALID NGRP.') + IF(ISTATE(2).NE.LL4) CALL XABORT('DELTA: INVALID LL4.') + NSTEP=ISTATE(6) +*---- +* COMPUTE THE GPT SOLUTION. +*---- + CALL DELDRV(IPTRK,IPSYS0,IPSYSP,IPFLU0,IPGPT,NUN,NGRP,NSTEP) +*---- +* RELEASE GENERAL TRACKING INFORMATION. +*---- + IF(JENTRY(1).EQ.0) THEN + CALL LCMPTC(IPGPT,'TRACK-TYPE',12,CMODUL) + ISTATE(:NSTATE)=0 + ISTATE(1)=NGRP + ISTATE(2)=NUN + CALL LCMLEN(IPGPT,'DSOUR',ILENG,ITYLCM) + IF(ILENG.NE.0) ISTATE(3)=ILENG + CALL LCMLEN(IPGPT,'ASOUR',ILENG,ITYLCM) + IF(ILENG.NE.0) ISTATE(4)=ILENG + CALL LCMPUT(IPGPT,'STATE-VECTOR',NSTATE,1,ISTATE) + ENDIF + RETURN + END |