initial upload
This commit is contained in:
239
src/cmo_get_attparam.f
Executable file
239
src/cmo_get_attparam.f
Executable file
@@ -0,0 +1,239 @@
|
||||
subroutine cmo_get_attparam(att_name_in,cmo_name,index,ctype,
|
||||
* crank,clen,cinter,cpers,cio,ierror_return)
|
||||
C
|
||||
C
|
||||
C#######################################################################
|
||||
C
|
||||
C PURPOSE -
|
||||
C
|
||||
C This routine returns Mesh Object information.
|
||||
C
|
||||
C INPUT ARGUMENTS -
|
||||
C
|
||||
C att_name - (character) The attribute to find
|
||||
C cmo_name - (character) Name of the Mesh Object.
|
||||
C
|
||||
C OUTPUT ARGUMENTS -
|
||||
C
|
||||
C index - attribute number
|
||||
C ctype - type
|
||||
C crank - rank
|
||||
C clen - length
|
||||
C cinter - interpolation
|
||||
C cpers - persistence
|
||||
C cio - ioflag
|
||||
C ierror_return - Error Return Code (==0 ==> OK, <>0 ==> Error).
|
||||
C
|
||||
C CHANGE HISTORY -
|
||||
C
|
||||
C $Log: cmo_get_attparam.f,v $
|
||||
C Revision 2.00 2007/11/05 19:45:48 spchu
|
||||
C Import to CVS
|
||||
C
|
||||
CPVCS
|
||||
CPVCS Rev 1.5 13 Apr 2006 14:20:20 tam
|
||||
CPVCS Illegal error messege removed and replaced with messege only if
|
||||
CPVCS idebug is greater than 1. This allows this routine to check for
|
||||
CPVCS existance of attribute without reporting an error all the time
|
||||
CPVCS
|
||||
CPVCS Rev 1.4 10 Apr 2001 11:04:16 dcg
|
||||
CPVCS shorten too long name
|
||||
CPVCS
|
||||
CPVCS Rev 1.3 22 Mar 2001 09:57:14 dcg
|
||||
CPVCS look for special name imt, itp, icr, isn and append '1' to end of name
|
||||
CPVCS to match default mesh object attribute name
|
||||
CPVCS
|
||||
CPVCS Rev 1.2 Wed Apr 05 13:34:12 2000 nnc
|
||||
CPVCS Minor source modifications required by the Absoft compiler.
|
||||
CPVCS
|
||||
CPVCS Rev 1.1 Mon Jan 31 13:23:24 2000 dcg
|
||||
CPVCS
|
||||
CPVCS Rev 1.19 Tue Oct 06 16:48:40 1998 dcg
|
||||
CPVCS make equivalent node attributes imt,imt1, itp,itp1,
|
||||
CPVCS icr,icr1,...
|
||||
CPVCS
|
||||
CPVCS Rev 1.18 Wed Dec 17 11:25:10 1997 dcg
|
||||
CPVCS declare iout as a pointe
|
||||
CPVCS
|
||||
CPVCS Rev 1.17 Mon Apr 14 16:41:12 1997 pvcs
|
||||
CPVCS No change.
|
||||
CPVCS
|
||||
CPVCS Rev 1.16 Wed Mar 06 16:44:04 1996 dcg
|
||||
CPVCS print error messages if idebug=1
|
||||
CPVCS
|
||||
CPVCS Rev 1.15 09/14/95 12:09:18 dcg
|
||||
CPVCS replace character literals in call argument lists
|
||||
CPVCS
|
||||
CPVCS Rev 1.14 09/13/95 14:32:16 het
|
||||
CPVCS Correct an error
|
||||
CPVCS
|
||||
CPVCS Rev 1.13 09/11/95 14:44:00 het
|
||||
CPVCS Change to the storage block based CMO stuff.
|
||||
CPVCS
|
||||
CPVCS Rev 1.12 08/30/95 21:08:46 het
|
||||
CPVCS Put cmo table data into the cmoatt storage block
|
||||
CPVCS
|
||||
CPVCS Rev 1.11 05/22/95 15:28:24 ejl
|
||||
CPVCS Added nfaces and nedges.
|
||||
CPVCS
|
||||
CPVCS Rev 1.10 03/15/95 15:22:58 ejl
|
||||
CPVCS Finished installing the defaults.
|
||||
CPVCS
|
||||
CPVCS Rev 1.9 02/16/95 09:56:14 ejl
|
||||
CPVCS Fixed bugs, fixed hole in the Create command.
|
||||
CPVCS Added commands MODATT, LENGTH, MEMORY, & COMPRESS.
|
||||
CPVCS
|
||||
CPVCS Rev 1.8 02/10/95 14:07:24 ejl
|
||||
CPVCS Fix bugs left from last update
|
||||
CPVCS
|
||||
CPVCS Rev 1.6 01/30/95 06:22:12 het
|
||||
CPVCS Fix several cmo errors
|
||||
CPVCS
|
||||
CPVCS Rev 1.5 01/24/95 08:52:42 het
|
||||
CPVCS Add error checking to the cmo routines.
|
||||
CPVCS
|
||||
CPVCS
|
||||
CPVCS Rev 1.4 01/04/95 22:01:34 llt
|
||||
CPVCS unicos changes (made by het)
|
||||
CPVCS
|
||||
CPVCS Rev 1.3 12/09/94 22:50:58 het
|
||||
CPVCS Made changes to support the new cmo_ routines.
|
||||
CPVCS
|
||||
CPVCS
|
||||
CPVCS Rev 1.2 12/01/94 18:58:44 het
|
||||
CPVCS Added a data variable type to the call.
|
||||
CPVCS
|
||||
CPVCS
|
||||
CPVCS Rev 1.1 11/28/94 14:14:44 het
|
||||
CPVCS Add the "mbndry" option.
|
||||
CPVCS
|
||||
CPVCS Rev 1.0 11/14/94 12:04:50 het
|
||||
CPVCS Original Version
|
||||
C
|
||||
C#######################################################################
|
||||
C
|
||||
implicit none
|
||||
C
|
||||
C#######################################################################
|
||||
C
|
||||
include 'cmo_lg.h'
|
||||
C
|
||||
C#######################################################################
|
||||
C
|
||||
character*(*) cmo_name,att_name_in
|
||||
character*32 partname,ctype,cpers,cio,clen,crank,cinter,name,
|
||||
* att_name
|
||||
integer posname,postype,posrank,posio,poslen,posint,pospers
|
||||
integer i,len1,len2, natts
|
||||
integer icharlnf
|
||||
C
|
||||
integer ierror_return
|
||||
C
|
||||
C#######################################################################
|
||||
C
|
||||
C LOCAL VARIABLE DEFINITION
|
||||
C
|
||||
integer len,ierr,icscode,icmo_index,index, idebug
|
||||
C
|
||||
character*132 logmess
|
||||
|
||||
C
|
||||
C#######################################################################
|
||||
C
|
||||
if((cmo_name.eq.'-cmo-') .or.
|
||||
* (cmo_name.eq.'-default-') .or.
|
||||
* (cmo_name.eq.'-def-')) then
|
||||
C
|
||||
C.... Use the Current Mesh Object.
|
||||
C
|
||||
call cmo_get_name(cmo_name,ierror_return)
|
||||
C
|
||||
endif
|
||||
C
|
||||
C
|
||||
C.... Search table for Mesh Object.
|
||||
C
|
||||
call cmo_exist(cmo_name,icscode)
|
||||
C
|
||||
C
|
||||
if(icscode.ne.0) then
|
||||
C
|
||||
ierror_return=-1
|
||||
C
|
||||
write(logmess,'(a,a)')
|
||||
* 'CMO_GET_INFO: Mesh Object does not exist: ', cmo_name
|
||||
call writloga('default',0,logmess,0,ierr)
|
||||
C
|
||||
else
|
||||
c
|
||||
c look for special names
|
||||
c
|
||||
C
|
||||
call cmo_get_intinfo('idebug',cmo_name,idebug,len,i,icscode)
|
||||
|
||||
att_name=att_name_in
|
||||
if(att_name_in.eq.'imt') att_name='imt1'
|
||||
if(att_name_in.eq.'itp') att_name='itp1'
|
||||
if(att_name_in.eq.'isn') att_name='isn1'
|
||||
if(att_name_in.eq.'icr') att_name='icr1'
|
||||
C
|
||||
c.... Find postions of name, type, rank and length
|
||||
partname='define_cmo_lg'
|
||||
call mmfindbk( 'defcmo_attparam_names',partname,
|
||||
* ipdefcmo_attparam_names,len,icscode)
|
||||
do i=1,number_of_default_attparam_name
|
||||
if(defcmo_attparam_names(i).eq.'name') posname=i
|
||||
if(defcmo_attparam_names(i).eq.'type') postype=i
|
||||
if(defcmo_attparam_names(i).eq.'rank') posrank=i
|
||||
if(defcmo_attparam_names(i).eq.'length') poslen=i
|
||||
if(defcmo_attparam_names(i).eq.'interpolation') posint=i
|
||||
if(defcmo_attparam_names(i).eq.'persistence') pospers=i
|
||||
if(defcmo_attparam_names(i).eq.'ioflag') posio=i
|
||||
enddo
|
||||
C
|
||||
C Loop through the attributes look for matching attribute
|
||||
C name - then check type
|
||||
C
|
||||
partname='define_cmo_lg'
|
||||
call mmfindbk('cmo_names',partname,ipcmo_names,len,
|
||||
* icscode)
|
||||
call mmfindbk('cmo_natts',partname,ipcmo_natts,len,
|
||||
* icscode)
|
||||
partname=cmo_name
|
||||
call mmfindbk('cmo_attlist',cmo_name,ipcmo_attlist,
|
||||
* len,icscode)
|
||||
call cmo_get_index(cmo_name,icmo_index,ierror_return)
|
||||
if(ierror_return.ne.0) go to 9998
|
||||
natts=cmo_natts(icmo_index)
|
||||
do i=1,natts
|
||||
name=cmo_attlist(number_of_params_per_att*(i-1)+posname)
|
||||
len1=icharlnf(name)
|
||||
len2=icharlnf(att_name)
|
||||
if(name(1:len1)
|
||||
* .eq.att_name(1:len2)) then
|
||||
index=i
|
||||
ctype=cmo_attlist(number_of_params_per_att*(i-1)+postype)
|
||||
crank=cmo_attlist(number_of_params_per_att*(i-1)+posrank)
|
||||
clen=cmo_attlist(number_of_params_per_att*(i-1)+poslen)
|
||||
cinter=cmo_attlist(number_of_params_per_att*(i-1)+posint)
|
||||
cpers=cmo_attlist(number_of_params_per_att*(i-1)+pospers)
|
||||
cio=cmo_attlist(number_of_params_per_att*(i-1)+posio)
|
||||
ierror_return=0
|
||||
go to 9999
|
||||
endif
|
||||
enddo
|
||||
ierror_return=1
|
||||
C
|
||||
C ierror_return is 0 if there are no errors
|
||||
9998 if(ierror_return.ne.0) then
|
||||
if (idebug.ge.1) then
|
||||
write(logmess,9000) cmo_name,att_name
|
||||
call writloga('default',0,logmess,0,ierr)
|
||||
9000 format('Attribute Error in cmo_get_attparam: ',2a32)
|
||||
endif
|
||||
endif
|
||||
C
|
||||
endif
|
||||
C
|
||||
9999 return
|
||||
end
|
||||
Reference in New Issue
Block a user